Floppyshop 2

home *** CD-ROM | disk | FTP | other *** search

/ Floppyshop 2 / Floppyshop - 2.zip / Floppyshop - 2.iso / diskmags / 0022-3.564 / dmg-0129 / general / xscheme.doc < prev

Wrap

Text File | 1997-04-16 | 175KB | 6,772 lines

XSCHEME: An Object-oriented Scheme Version 0.17 (not yet updated for version 0.22 (BCB)) March 2, 1989 by David Michael Betz P.O. Box 144 Peterborough, NH 03458 (603) 924-4145 (home) Copyright (c) 1989, by David Michael Betz All Rights Reserved Permission is granted for unrestricted non-commercial use XSCHEME TABLE OF CONTENTS Page 2 TABLE OF CONTENTS TABLE OF CONTENTS..................................2 INTRODUCTION.......................................3 A NOTE FROM THE AUTHOR.............................4 EXPRESSIONS........................................5 BINDING FORMS.....................................10 SEQUENCING........................................11 DELAYED EVALUATION................................12 ITERATION.........................................13 DEFINITIONS.......................................14 LIST FUNCTIONS....................................15 DESTRUCTIVE LIST FUNCTIONS........................17 SYMBOL FUNCTIONS..................................18 VECTOR FUNCTIONS..................................19 ARRAY FUNCTIONS...................................20 CONVERSION FUNCTIONS..............................21 TYPE PREDICATES...................................22 EQUALITY PREDICATES...............................25 ARITHMETIC FUNCTIONS..............................26 NUMERIC COMPARISON FUNCTIONS......................29 BITWISE LOGICAL FUNCTIONS.........................30 STRING FUNCTIONS..................................31 STRING COMPARISON FUNCTIONS.......................32 CHARACTER COMPARISON FUNCTIONS....................33 INPUT/OUTPUT FUNCTIONS............................34 OUTPUT CONTROL FUNCTIONS..........................36 FILE I/O FUNCTIONS................................37 CONTROL FEATURES..................................39 ENVIRONMENT FUNCTIONS.............................40 UTILITY FUNCTIONS.................................41 SYSTEM FUNCTIONS..................................42 OBJECT REPRESENTATIONS............................43 XSCHEME INTRODUCTION Page 3 XScheme is an implementation of the Scheme programming language with extensions to support object-oriented programming. There are currently implementations of XScheme running on the IBM-PC and clones under MS-DOS, on the Macintosh, the Atari-ST and the Amiga. It is completely written in the programming language 'C' and is easily extended with user written built-in functions and classes. It is available in source form to non- commercial users. This document is a brief description of XScheme. XScheme follows the "Revised^3 Report on the Algorithmic Language Scheme". It assumes some knowledge of Scheme or LISP and some understanding of the concepts of object-oriented programming. I recommend the book "Structure and Interpretation of Computer Programs" by Harold Abelson and Gerald Jay Sussman and published by The MIT Press and the McGraw-Hill Book Company for learning Scheme (and programming in general). You might also find "The Scheme Programming Language" by R. Kent Dybvig and "The Little Lisper" by Daniel P. Friedman and Matthias Felleisen to be helpful. XSCHEME A NOTE FROM THE AUTHOR Page 4 A NOTE FROM THE AUTHOR If you have any problems with XScheme, feel free to contact me for help or advice. Please remember that since XScheme is available in source form in a high level language, many users have been making versions available on a variety of machines. If you call to report a problem with a specific version, I may not be able to help you if that version runs on a machine to which I don't have access. Please have the version number of the version that you are running readily accessible before calling me. If you find a bug in XScheme, first try to fix the bug yourself using the source code provided. If you are successful in fixing the bug, send the bug report along with the fix to me. If you don't have access to a C compiler or are unable to fix a bug, please send the bug report to me and I'll try to fix it. Any suggestions for improvements will be welcomed. Feel free to extend the language in whatever way suits your needs. However, PLEASE DO NOT RELEASE ENHANCED VERSIONS WITHOUT CHECKING WITH ME FIRST!! I would like to be the clearing house for new features added to XScheme. If you want to add features for your own personal use, go ahead. But, if you want to distribute your enhanced version, contact me first. XSCHEME EXPRESSIONS Page 5 EXPRESSIONS <variable> An expression consisting of a variable is a variable reference. The value of the variable reference is the value stored in the location to which the variable is bound. It is an error to reference an unbound variable. (QUOTE <datum>) '<datum> (quote <datum>) evaluates to <datum>. <Datum> may be any external representation of a Scheme object. This notation is used to include literal constants in Scheme code. (quote <datum>) may be abbreviated as '<datum>. The two notations are equivalent in all respects. <constant> Numeric constants, string constants, character constants, and boolean constants evaluate "to themselves"; they need not be quoted. (<operator> <operand>...) A procedure call is written by simply enclosing in parentheses expressions for the procedure to be called and the arguments to be passed to it. The operator and operand expressions are evaluated and the resulting procedure is passed the resulting arguments. (<object> <selector> <operand>...) A message sending form is written by enclosing in parentheses expressions for the receiving object, the message selector, and the arguments to be passed to the method. The receiver, selector, and argument expressions are evaluated, the message selector is used to select an appropriate method to handle the message, and the resulting method is passed the resulting arguments. XSCHEME EXPRESSIONS Page 6 (LAMBDA <formals> <body>) <Formals> should be a formal argument list as described below, and <body> should be a sequence of one or more expressions. A lambda expression evaluates to a procedure. The environment in effect when the lambda expression is evaluated is remembered as part of the procedure. When the procedure is later called with some actual arguments, the environment in which the lambda expression was evaluated will be extended by binding the variables in the formal argument list to fresh locations, the corresponding actual argument values will be stored in those locations, and the expressions in the body of the lambda expression will be evaluated sequentially in the extended environment. The result of the last expression in the body will be returned as the result of the procedure call. <Formals> should have the following form: (<var>... [#!OPTIONAL <ovar>...] [. <rvar>]) or (<var>... [#!OPTIONAL <ovar>...] [#!REST <rvar>]) where: <var> is a required argument <ovar> is an optional argument <rvar> is a "rest" argument There are three parts to a <formals> list. The first lists the required arguments of the procedure. All calls to the procedure must supply values for each of the required arguments. The second part lists the optional arguments of the procedure. An optional argument may be supplied in a call or omitted. If it is omitted, a special value is given to the argument that satisfies the default-object? predicate. This provides a way to test to see if an optional argument was provided in a call or omitted. The last part of the <formals> list gives the "rest" argument. This argument will be bound to the rest of the list of arguments supplied to a call after the required and optional arguments have been removed. XSCHEME EXPRESSIONS Page 7 (IF <test> <consequent> [<alternate>]) An if expression is evaluated as follows: first, <test> is evaluated. If it yields a true value, then <consequent> is evaluated and its value is returned. Otherwise, <alternate> is evaluated and its value is returned. If <test> yields a false value and no <alternate> is specified, then the result of the expression is unspecified. (ACCESS <variable> <env>) <Env> is evaluated producing an environment. The result is the value of <variable> in this environment. (SET! <variable> <expression>) <Expression> is evaluated, and the resulting value is stored in the location to which <variable> is bound. <Variable> must be bound in some region or at the top level. The result of the set! expression is unspecified. (SET! (ACCESS <variable> <env>) <value>) <Env> is evaluated producing an environment. <Value> is evaluated and the resulting value is stored as the value of <variable> in this environment. The result of the set! expression is unspecified. XSCHEME EXPRESSIONS Page 8 (COND <clause>...) Each clause should be of the form (<test> <expression>...) where <test> is any expression. The last <clause> may be an "else clause," which has the form (ELSE <expression>...) A cond expression is evaluated by evaluating the <test> expressions of successive <clause>s in order until one of them evaluates to a true value. When a <test> evaluates to a true value, then the remaining <expression>s in its <clause> are evaluated in order, and the result of the last <expression> in the <clause> is returned as the result of the entire cond expression. If the selected <clause> contains only the <test> and no <expression>s, then the value of the <test> is returned as the result. If all <test>s evaluate to false values, and there is no else clause, then the result of the conditional expression is unspecified; if there is an else clause, then its <expression>s are evaluated, and the value of the last one is returned. XSCHEME EXPRESSIONS Page 9 (AND <test>...) The <test> expressions are evaluated from left to right, and the value of the first expression that evaluates to a false value is returned. Any remaining expressions are not evaluated. If all the expressions evaluate to true values, the value of the last expression is returned. If there are no expressions then #t is returned. (OR <test>...) The <test> expressions are evaluated from left to right, and the value of the first expression that evaluates to a true value is returned. Any remaining expressions are not evaluated. If all expressions evaluate to false values, the value of the last expression is returned. If there are no expressions then #f is returned. XSCHEME BINDING FORMS Page 10 BINDING FORMS (LET [<name>] <bindings> <body>) <Bindings> should have the form ((<variable> <init>)...) where each <init> is an expression, and <body> should be a sequence of one or more expressions. The <init>s are evaluated in the current envirnoment, the <variable>s are bound to fresh locations holding the results, the <body> is evaluated in the extended environment, and the value of the last expression of <body> is returned. Each binding of a <variable> has <body> as its region. If a name is supplied, a procedure that takes the bound variables as its arguments and has the body of the LET as its body is bound to that name. (LET* <bindings> <body>) Same as LET except that the bindings are done sequentially from left to right and the bindings to the left are visible while evaluating the initialization expressions for each variable. (LETREC <bindings> <body>) <Bindings> should have the form ((<variable> <init>)...) and <body> should be a sequence of one or more expressions. The <variable>s are bound to fresh locations holding undefined values; the <init>s are evaluated in the resulting environment; each <variable> is assigned to the result of the corresponding <init>; the <body> is evaluated in the resulting environment; and the value of the last expression in <body> is returned. Each binding of a <variable> has the entire letrec expression as its region, making it possible to define mutually recursive procedures. One restriction of letrec is very important: it must be possible to evaluate each <init> without referring to the value of any <variable>. If this restriction is violated, then the effect is undefined, and an error may be signalled during evaluation of the <init>s. The restriction is necessary because Scheme passes arguments by value rather than by name. In the most common uses of letrec, all the <init>s are lambda expressions and the restriction is satisfied automatically. XSCHEME SEQUENCING Page 11 SEQUENCING (BEGIN <expression>...) (SEQUENCE <expression>...) The <expression>s are evaluated sequentially from left to right, and the value of the last <expression> is returned. This expression type is used to sequence side effects such as input and output. XSCHEME DELAYED EVALUATION Page 12 DELAYED EVALUATION (CONS-STREAM expr1 expr2) Create a cons stream whose head is expr1 (which is evaluated immediately) and whose tail is expr2 (whose evaluation is delayed until TAIL is called). To use CONS-STREAM, enter the following access procedures: (define head car) (define (tail stream) (force (cdr stream))) (DELAY <expression>) Evaluating this expression creates a "promise" to evaluate <expression> at a later time. (FORCE promise) Applying FORCE to a promise generated by DELAY requests that the promise produce the value of the expression passed to DELAY. The first time a promise is FORCEed, the DELAY expression is evaluated and the value stored. On subsequent calls to FORCE with the same promise, the saved value is returned. XSCHEME ITERATION Page 13 ITERATION (WHILE <test> <expression>...) While is an iteration construct. Each iteration begins by evaluating <test>; if the result is false, then the loop terminates and the value of <test> is returned as the value of the while expression. If <test> evaluates to a true value, then the <expression>s are evaluated in order for effect and the next iteration begins. XSCHEME DEFINITIONS Page 14 DEFINITIONS (DEFINE <variable> <expression>) Define a variable and give it an initial value. (DEFINE (<variable> <formals>) <body>) Define a procedure. XSCHEME LIST FUNCTIONS Page 15 LIST FUNCTIONS (CONS expr1 expr2) Create a new pair whose car is expr1 and whose cdr is expr2. (CAR pair) Extract the car of a pair. (CDR pair) Extract the cdr of a pair. (CxxR pair) (CxxxR pair) (CxxxxR pair) These functions are short for combinations of CAR and CDR. Each 'x' is stands for either 'A' or 'D'. An 'A' stands for the CAR function and a 'D' stands for the CDR function. For instance, (CADR x) is the same as (CAR (CDR x)). (LIST expr...) Create a list whose elements are the arguments to the function. This function can take an arbitrary number of arguments. Passing no arguments results in the empty list. (APPEND list...) Append lists to form a single list. This function takes an arbitrary number of arguments. Passing no arguments results in the empty list. (REVERSE list) Create a list whose elements are the same as the argument except in reverse order. (LAST-PAIR list) Return the last pair in a list. (LENGTH list) Compute the length of a list. XSCHEME LIST FUNCTIONS Page 16 (MEMBER expr list) (MEMV expr list) (MEMQ expr list) Find an element in a list. Each of these functions searches the list looking for an element that matches expr. If a matching element is found, the remainder of the list starting with that element is returned. If no matching element is found, the empty list is returned. The functions differ in the test used to determine if an element matches expr. The MEMBER function uses EQUAL?, the MEMV function uses EQV? and the MEMQ function uses EQ?. (ASSOC expr alist) (ASSV expr alist) (ASSQ expr alist) Find an entry in an association list. An association list is a list of pairs. The car of each pair is the key and the cdr is the value. These functions search an association list for a pair whose key matches expr. If a matching pair is found, it is returned. Otherwise, the empty list is returned. The functions differ in the test used to determine if a key matches expr. The ASSOC function uses EQUAL?, the ASSV function uses EQV? and the ASSQ function uses EQ?. (LIST-REF list n) Return the nth element of a list (zero based). (LIST-TAIL list n) Return the sublist obtained by removing the first n elements of list. XSCHEME DESTRUCTIVE LIST FUNCTIONS Page 17 DESTRUCTIVE LIST FUNCTIONS (SET-CAR! pair expr) Set the car of a pair to expr. The value returned by this procedure is unspecified. (SET-CDR! pair expr) Set the cdr of a pair to expr. The value returned by this procedure is unspecified. XSCHEME SYMBOL FUNCTIONS Page 18 SYMBOL FUNCTIONS (BOUND? sym) Returns #t if a global value is bound to the symbol and #f otherwise. (SYMBOL-VALUE sym) Get the global value of a symbol. (SET-SYMBOL-VALUE! sym expr) Set the global value of a symbol. The value returned by this procedure is unspecified. (SYMBOL-PLIST sym) Get the property list associated with a symbol. (SET-SYMBOL-PLIST! sym plist) Set the property list associate with a symbol. The value returned by this procedure is unspecified. (GENSYM [sym|str|num]) Generate a new, uninterned symbol. The print name of the symbol will consist of a prefix with a number appended. The initial prefix is "G" and the initial number is 1. If a symbol is specified as an argument, the prefix is set to the print name of that symbol. If a string is specified, the prefix is set to that string. If a number is specified, the numeric suffix is set to that number. After the symbol is generated, the number is incremented so subsequent calls to GENSYM will generate numbers in sequence. (GET sym prop) Get the value of a property of a symbol. The prop argument is a symbol that is the property name. If a property with that name exists on the symbols property list, the value of the property is returned. Otherwise, the empty list is returned. (PUT sym prop expr) Set the value of a property of a symbol. The prop argument is a symbol that is the property name. The property/value combination is added to the property list of the symbol. XSCHEME VECTOR FUNCTIONS Page 19 VECTOR FUNCTIONS (VECTOR expr...) Create a vector whose elements are the arguments to the function. This function can take an arbitrary number of arguments. Passing no arguments results in a zero length vector. (MAKE-VECTOR len) Make a vector of the specified length. (VECTOR-LENGTH vect) Get the length of a vector. (VECTOR-REF vect n) Return the nth element of a vector (zero based). (VECTOR-SET! vect n expr) Set the nth element of a vector (zero based). XSCHEME ARRAY FUNCTIONS Page 20 ARRAY FUNCTIONS (MAKE-ARRAY d1 d2...) Make an array (vector of vectors) with the specified dimensions. At least one dimension must be specified. (ARRAY-REF array s1 s2...) Get an array element. The sn arguments are integer subscripts (zero based). (ARRAY-SET! array s1 s2... expr) Set an array element. The sn arguments are integer subscripts (zero based). XSCHEME CONVERSION FUNCTIONS Page 21 CONVERSION FUNCTIONS (SYMBOL->STRING sym) Convert a symbol to a string. Returns the print name of the symbol as a string. (STRING->SYMBOL str) Convert a string to a symbol. Returns a symbol with the string as its print name. This can either be a new symbol or an existing one with the same print name. (VECTOR->LIST vect) Convert a vector to a list. Returns a list of the elements of the vector. (LIST->VECTOR list) Convert a list to a vector. Returns a vector of the elements of the list. (STRING->LIST str) Convert a string to a list. Returns a list of the characters in the string. (LIST->STRING list) Convert a list of character to a string. Returns a string whose characters are the elements of the list. (CHAR->INTEGER char) Convert a character to an integer. Returns the ASCII code of the character as an integer. (INTEGER->CHAR n) Convert an integer ASCII code to a character. Returns the character whose ASCII code is the integer. XSCHEME TYPE PREDICATES Page 22 TYPE PREDICATE FUNCTIONS (NOT expr) Returns #t if the expression is #f and #t otherwise. (NULL? expr) Returns #t if the expression is the empty list and #f otherwise. (ATOM? expr) Returns #f if the expression is a pair and #t otherwise. (LIST? expr) Returns #t if the expression is either a pair or the empty list and #f otherwise. (NUMBER? expr) Returns #t if the expression is a number and #f otherwise. (BOOLEAN? expr) Returns #t if the expression is either #t or #f and #f otherwise. (PAIR? expr) Returns #t if the expression is a pair and #f otherwise. (SYMBOL? expr) Returns #t if the expression is a symbol and #f otherwise. (COMPLEX? expr) Returns #t if the expression is a complex number and #f otherwise. Note: Complex numbers are not yet supported by XScheme. (REAL? expr) Returns #t if the expression is a real number and #f otherwise. XSCHEME TYPE PREDICATES Page 23 (RATIONAL? expr) Returns #t if the expression is a rational number and #f otherwise. Note: Rational numbers are not yet supported by XScheme. (INTEGER? expr) Returns #t if the expression is an integer and #f otherwise. (CHAR? expr) Returns #t if the expression is a character and #f otherwise. (STRING? expr) Returns # if the expression is a string and #f otherwise. (VECTOR? expr) Returns #t if the expression is a vector and #f otherwise. (PROCEDURE? expr) Returns #t if the expression is a procedure (closure) and #f otherwise. (PORT? expr) Returns #t if the expression is a port and #f otherwise. (INPUT-PORT? expr) Returns #t if the expression is an input port and #f otherwise. (OUTPUT-PORT? expr) Returns #t if the expression is an output port and #f otherwise. (OBJECT? expr) Returns #t if the expression is an object and #f otherwise. XSCHEME TYPE PREDICATES Page 24 (EOF-OBJECT? expr) Returns #t if the expression is the object returned by READ upon detecting an end of file condition and #f otherwise. (DEFAULT-OBJECT? expr) Returns #t if the expression is the object passed as the default value of an optional parameter to a procedure when that parameter is omitted from a call and #f otherwise. (ENVIRONMENT? x) Returns #t if the expression is an environment and #f otherwise. XSCHEME EQUALITY PREDICATES Page 25 EQUALITY PREDICATES (EQUAL? expr1 expr2) Recursively compares two objects to determine if their components are the same and returns #t if they are the same and #f otherwise. (EQV? expr1 expr2) Compares two objects to determine if they are the same object. Returns #t if they are the same and #f otherwise. This function does not compare the elements of lists, vectors or strings but will compare all types of numbers. (EQ? expr1 expr2) Compares two objects to determine if they are the same object. Returns #t if they are the same and #f otherwise. This function performs a low level address compare on two objects and may return #f for objects that appear on the surface to be the same. This is because the objects are not stored uniquely in memory. For instance, numbers may appear to be equal, but EQ? will return #f when comparing them if they are stored at different addresses. The advantage of this function is that it is faster than the others. Symbols are guaranteed to compare correctly, so EQ? can safely be used to compare them. XSCHEME ARITHMETIC FUNCTIONS Page 26 ARITHMETIC FUNCTIONS (ZERO? n) Returns #t if the number is zero and #f otherwise. (POSITIVE? n) Returns #t if the number is positive and #f otherwise. (NEGATIVE? n) Returns #t if the number is negative and #f otherwise. (ODD? n) Returns #t if the integer is odd and #f otherwise. (EVEN? n) Returns #t if the integer is even and #f otherwise. (EXACT? n) Returns #t if the number is exact and #f otherwise. Note: This function always returns #f in XScheme since exact numbers are not yet supported. (INEXACT? n) Returns #t if the number is inexact and #f otherwise. Note: This function always returns #t in XScheme since exact numbers are not yet supported. (TRUNCATE n) Truncates a number to an integer and returns the resulting value. (FLOOR n) Returns the largest integer not larger than n. (CEILING n) Returns the smallest integer not smaller than n. (ROUND n) Returns the closest integer to n, rounding to even when n is halfway between two integers. (1+ n) XSCHEME ARITHMETIC FUNCTIONS Page 27 Returns the result of adding one to the number. (-1+ n) Returns the result of subtracting one from the number. (ABS n) Returns the absolute value of the number. (GCD n1 n2) Returns the greatest common divisor of the two numbers. (RANDOM n) Returns a random number between zero and n-1 (n must be an integer). (+ n1 n2...) Returns the sum of the numbers. (- n) Negates the number and returns the resulting value. (- n1 n2...) Subtracts each remaining number from n1 and returns the resulting value. (* n1 n2...) Multiples the numbers and returns the resulting value. (/ n) Returns 1/n. (/ n1 n2...) Divides n1 by each of the remaining numbers and returns the resulting value. (QUOTIENT n1 n2...) Divides the integer n1 by each of the remaining numbers and returns the resulting integer quotient. This function does integer division. (REMAINDER n1 n2) Divides the integer n1 by the integer n2 and returns the XSCHEME ARITHMETIC FUNCTIONS Page 28 remainder. (MIN n1 n2...) Returns the number with the minimum value. (MAX n1 n2...) Returns the number with the maximum value. (SIN n) Returns the sine of the number. (COS n) Returns the cosine of the number. (TAN n) Returns the tangent of the number. (ASIN n) Returns the arc-sine of the number. (ACOS n) Returns the arc-cosine of the number. (ATAN x) Returns the arc-tangent of x. (ATAN y x) Returns the arc-tangent of y/x. (EXP n) Returns e raised to the n. (SQRT n) Returns the square root of n. (EXPT n1 n2) Returns n1 raised to the n2 power. (LOG n) Returns the natural logarithm of n. XSCHEME NUMERIC COMPARISON FUNCTIONS Page 29 NUMERIC COMPARISON FUNCTIONS (< n1 n2...) (= n1 n2...) (> n1 n2...) <<= n1 n2...) (>= n1 n2...) These functions compare numbers and return #t if the numbers match the predicate and #f otherwise. For instance, (< x y z) will return #t if x is less than y and y is less than z. XSCHEME BITWISE LOGICAL FUNCTIONS Page 30 BITWISE LOGICAL FUNCTIONS (LOGAND n1 n2...) Returns the bitwise AND of the integer arguments. (LOGIOR n1 n2...) Returns the bitwise inclusive OR of the integer arguments. (LOGXOR n1 n2...) Returns the bitwise exclusive OR of the integer arguments. (LOGNOT n) Returns the bitwise complement of n. XSCHEME STRING FUNCTIONS Page 31 STRING FUNCTIONS (STRING-LENGTH str) Returns the length of the string. (STRING-NULL? str) Returns #t if the string has a length of zero and #f otherwise. (STRING-APPEND str1...) Returns the result of appending the string arguments. If no arguments are supplied, it returns the null string. (STRING-REF str n) Returns the nth character in a string. (SUBSTRING str start end) Returns the substring of str starting at start and ending at end (integers). The range is inclusive of start and exclusive of end. XSCHEME STRING COMPARISON FUNCTIONS Page 32 STRING COMPARISON FUNCTIONS (STRING<? str1 str2) (STRING=? str1 str2) (STRING>? str1 str2) (STRING<=? str1 str2) (STRING>=? str1 str2) These functions compare strings and return #t if the strings match the predicate and #f otherwise. For instance, (STRING< x y) will return #t if x is less than y. Case is significant. #A does not match #a. (STRING-CI<? str1 str2) (STRING-CI=? str1 str2) (STRING-CI>? str1 str2) (STRING-CI<=? str1 str2) (STRING-CI>=? str1 str2) These functions compare strings and return #t if the strings match the predicate and #f otherwise. For instance, (STRING-CI< x y) will return #t if x is less than y. Case is not significant. #A matches #a. XSCHEME CHARACTER COMPARISON FUNCTIONS Page 33 CHARACTER COMPARISON FUNCTIONS (CHAR<? ch1 ch2) (CHAR=? ch1 ch2) (CHAR>? ch1 ch2) (CHAR<=? ch1 ch2) (CHAR>=? ch1 ch2) These functions compare characters and return #t if the characters match the predicate and #f otherwise. For instance, (CHAR< x y) will return #t if x is less than y. Case is significant. #A does not match #a. (CHAR-CI<? ch1 ch2) (CHAR-CI=? ch1 ch2) (CHAR-CI>? ch1 ch2) (CHAR-CI<=? ch1 ch2) (CHAR-CI>=? ch1 ch2) These functions compare characters and return #t if the characters match the predicate and #f otherwise. For instance, (CHAR-CI< x y) will return #t if x is less than y. Case is not significant. #A matchs #a. XSCHEME INPUT/OUTPUT FUNCTIONS Page 34 INPUT/OUTPUT FUNCTIONS (READ [port]) Reads an expression from the specified port. If no port is specified, the current input port is used. Returns the expression read or an object that satisfies the default-object? predicate if it reaches the end of file on the port. (READ-CHAR [port]) Reads a character from the specified port. If no port is specified, the current input port is used. Returns the character read or an object that satisfies the default-object? predicate if it reaches the end of file on the port. (READ-BYTE [port]) Reads a byte from the specified port. If no port is specified, the current input port is used. Returns the byte read or an object that satisfies the default- object? predicate if it reaches the end of file on the port. (WRITE expr [port]) (PRIN1 expr [port]) Writes an expression to the specified port. If no port is specified, the current output port is used. The expression is written such that the READ function can read it back. This means that strings will be enclosed in quotes and characters will be printed with # notation. (WRITE-CHAR ch [port]) Writes a character to the specified port. If no port is specified, the current output port is used. (WRITE-BYTE ch [port]) Writes a byte to the specified port. If no port is specified, the current output port is used. (DISPLAY expr [port]) (PRINC expr [port]) Writes an expression to the specified port. If no port is specified, the current output port is used. The expression is written without any quoting characters. No quotes will appear around strings and characters are written without the # notation. XSCHEME INPUT/OUTPUT FUNCTIONS Page 35 (NEWLINE [port]) Starts a new line on the specified port. If no port is specified, the current output port is used. XSCHEME OUTPUT CONTROL FUNCTIONS Page 36 OUTPUT CONTROL FUNCTIONS (PRINT-BREADTH [n]) Controls the maximum number of elements of a list that will be printed. If n is an integer, the maximum number is set to n. If it is #f, the limit is set to infinity. This is the default. If n is omitted from the call, the current value is returned. (PRINT-DEPTH [n]) Controls the maximum number of levels of a nested list that will be printed. If n is an integer, the maximum number is set to n. If it is #f, the limit is set to infinity. This is the default. If n is omitted from the call, the current value is returned. XSCHEME FILE I/O FUNCTIONS Page 37 FILE I/O FUNCTIONS All four of the following OPEN functions take an optional argument to indicate that file I/O is to be done in binary mode. For binary files, this argument should be the symbol BINARY. For text files, the argument can be left out or the symbol TEXT can be supplied. (OPEN-INPUT-FILE str ['binary]) Opens the file named by the string and returns an input port. (OPEN-OUTPUT-FILE str ['binary]) Creates the file named by the string and returns an output port. (OPEN-APPEND-FILE str ['binary]) Opens the file named by the string for appending returns an output port. (OPEN-UPDATE-FILE str ['binary]) Opens the file named by the string for input and output and returns an input/output port. (GET-FILE-POSITION port) Returns the current file position as an offset in bytes from the beginning of the file. (SET-FILE-POSITION! port offset whence) Sets the current file position as an offset in bytes from the beginning of the file (when whence equals 0), the current file position (when whence equals 1) or the end of the file (when whence equals 2). Returns the new file position as an offset from the start of the file. (CLOSE-PORT port) Closes any port. (CLOSE-INPUT-PORT port) Closes an input port. (CLOSE-OUTPUT-PORT port) Closes an output port. XSCHEME FILE I/O FUNCTIONS Page 38 (CALL-WITH-INPUT-FILE str proc) Open the file whose name is specifed by str and call proc passing the resulting input port as an argument. When proc returns, close the file and return the value returned by proc as the result. (CALL-WITH-OUTPUT-FILE str proc) Create the file whose name is specifed by str and call proc passing the resulting output port as an argument. When proc returns, close the file and return the value returned by proc as the result. (CURRENT-INPUT-PORT) Returns the current input port. (CURRENT-OUTPUT-PORT) Returns the current output port. XSCHEME CONTROL FEATURES Page 39 CONTROL FEATURES (EVAL expr) Evaluate the expression in the global environment and return its value. (APPLY proc args) Apply the procedure to the list of arguments and return the result. (MAP proc list...) Apply the procedure to argument lists formed by taking corresponding elements from each list. Form a list from the resulting values and return that list as the result of the MAP call. (FOR-EACH fun list...) Apply the procedure to argument lists formed by taking corresponding elements from each list. The values returned by the procedure applications are discarded. The value returned by FOR-EACH is unspecified. (CALL-WITH-CURRENT-CONTINUATION proc) (CALL/CC proc) Form an "escape procedure" from the current continuation and pass it as an argument to proc. Calling the escape procedure with a single argument will cause that argument to be passed to the continuation that was in effect when the CALL-WITH-CURRENT-CONTINUATION procedure was called. XSCHEME ENVIRONMENT FUNCTIONS Page 40 ENVIRONMENT FUNCTIONS (THE-ENVIRONMENT) Returns the current environment. (PROCEDURE-ENVIRONMENT proc) Returns the environment from a procedure closure. (ENVIRONMENT-BINDINGS env) Returns an association list corresponding to the top most frame of the specified environment. (ENVIRONMENT-PARENT env) Returns the parent environment of the specified environment. XSCHEME UTILITY FUNCTIONS Page 41 UTILITY FUNCTIONS (LOAD str) Read and evaluate each expression from the specified file. (LOAD-NOISILY str) Read and evaluate each expression from the specified file and print the results to the current output port. (TRANSCRIPT-ON str) Opens a transcript file with the specified name and begins logging the interactive session to that file. (TRANSCRIPT-OFF) Closes the current transcript file. (EXIT) Exits from XScheme back to the operating system. (GC [ni vi]) Invokes the garbage collector and returns information on memory usage. If ni and vi are specified, they must be integers. Node and vector space are expanded by those amounts respectively and no garbage collection is triggered. GC returns an array of six values: the number of calls to the garbage collector, the total number of nodes, the current number of free nodes, the number of node segments, the number of vector segments and the total number of bytes allocated to the heap. (RESET) Returns to the top level read/eval/print loop. XSCHEME SYSTEM FUNCTIONS Page 42 SYSTEM FUNCTIONS (%CAR pair) (%CDR pair) (%SET-CAR! pair expr) (%SET-CDR! pair expr) (%VECTOR-LENGTH vect) (%VECTOR-REF vect n) (%VECTOR-SET! vect n expr) These functions do the same as their counterparts without the leading '%' character. The difference is that they don't check the type of their first argument. This makes it possible to examine data structures that have the same internal representation as pairs and vectors. It is *very* dangerous to modify objects using these functions and there is no guarantee that future releases of XScheme will represent objects in the same way that the current version does. XSCHEME OBJECT REPRESENTATIONS Page 43 OBJECT REPRESENTATIONS This version of XScheme uses the following object representations: Closures are represented as pairs. The car of the pair is the compiled function and the cdr of the pair is the saved environment. Compiled functions are represented as vectors. The element at offset 0 is the bytecode string. The element at offset 1 is the function name. The element at offset 2 is a list of names of the function arguments. The elements at offsets above 2 are the literals refered to by the compiled bytecodes. Environments are represented as lists of vectors. Each vector is an environment frame. The element at offset 0 is a list of the symbols that are bound in that frame. The symbol values start at offset 1. Objects are represented as vectors. The element at offset 0 is the class of the object. The remaining elements are the object's instance variable values. onments are represented as lists of vectors. Each vector is an environment frame. The element at scm/ 6 31 (define (%expand-macros expr) (if (pair? expr) (if (symbol? (car expr)) (let ((expander (get (car expr) '%syntax))) (if expander (expander expr) (let ((expander (get (car expr) '%macro))) (if expander (%expand-macros (expander expr)) (cons (car expr) (%expand-list (cdr expr))))))) (%expand-list expr)) expr)) (define (%expand-list lyst) (if (pair? lyst) (cons (%expand-macros (car lyst)) (%expand-list (cdr lyst))) lyst)) (define (compile expr #!optional env) (if (default-object? env) (%compile (%expand-macros expr)) (%compile (%expand-macros expr) env))) (put 'macro '%macro (lambda (form) (list 'put (list 'quote (cadr form)) (list 'quote '%macro) (caddr form)))) (macro syntax (lambda (form) #f)) (macro compiler-syntax (lambda (form) (list 'put (list 'quote (cadr form)) (list 'quote '%syntax) (caddr form)))) (compiler-syntax quote (lambda (form) form)) (compiler-syntax lambda (lambda (form) (cons 'lambda (cons (cadr form) (%expand-list (cddr form)))))) (compiler-syntax define (lambda (form) (cons 'define (cons (cadr form) (%expand-list (cddr form)))))) (compiler-syntax set! (lambda (form) (cons 'set! (cons (cadr form) (%expand-list (cddr form)))))) (define (%cond-expander lyst) (cond ((pair? lyst) (cons (if (pair? (car lyst)) (%expand-list (car lyst)) (car lyst)) (%cond-expander (cdr lyst)))) (else lyst))) (compiler-syntax cond (lambda (form) (cons 'cond (%cond-expander (cdr form))))) ; The following code for expanding let/let*/letrec was donated by: ; ; Harald Hanche-Olsen ; The University of Trondheim ; The Norwegian Institute of Technology ; Division of Mathematics ; N-7034 Trondheim NTH ; Norway (define (%expand-let-assignment pair) (if (pair? pair) (cons (car pair) (%expand-macros (cdr pair))) pair)) (define (%expand-let-form form) (cons (car form) (cons (let ((lyst (cadr form))) (if (pair? lyst) (map %expand-let-assignment lyst) lyst)) (%expand-list (cddr form))))) (compiler-syntax let %expand-let-form) (compiler-syntax let* %expand-let-form) (compiler-syntax letrec %expand-let-form) (macro define-integrable (lambda (form) (cons 'define (cdr form)))) (macro declare (lambda (form) #f)) (car pair) (%expand-macros (cdr pair))) pair)) (define (%expand-let-form form) (cons (car form) (cons (let ((lyst (cadr form))) (if (pair? lyst) (map %expand-let-assignment lyst) lyst)) (%expand-list (cddr form))))) (compiler-syntax let %expand-let-form) (compiler-syntax let* %expand-let-form) (compiler-syntax letrec %expand-let-form) (macro define-integrable (lambda (form) (cons 'definescm/qquote.s 03604 6363 ;; Expands QUASIQUOTE/UNQUOTE/UNQUOTE according to Rev^3 Report specs. ;; ;; This file can be included as is in XSCHEME.INI, or can be incorporated ;; into MACROS.S, with expander functions anywhere and macros after ;; after definition of COMPILER-SYNTAX ;;; EXPANDER-FUNCTIONS: compilable under the core XSCHEME, can be evaluated ;;; independently of MACRO system (define APPEND-ME-SYM (gensym)) ;; must be a gensym to avoid capture in ;; certain (pathological) situations (define QQ-EXPANDER (lambda (l) (letrec ( (qq-lev 0) ; always >= 0 (QQ-CAR-CDR (lambda (exp) (let ((qq-car (qq (car exp))) (qq-cdr (qq (cdr exp)))) (if (and (pair? qq-car) (eq? (car qq-car) append-me-sym)) (list 'append (cdr qq-car) qq-cdr) (list 'cons qq-car qq-cdr))))) (QQ (lambda (exp) (cond ((symbol? exp) (list 'quote exp)) ((vector? exp) (list 'list->vector (qq (vector->list exp)))) ((atom? exp) ; nil, number or boolean exp) ((eq? (car exp) 'quasiquote) (set! qq-lev (1+ qq-lev)) (let ((qq-val (if (= qq-lev 1) ; min val after inc ; --> outermost level (qq (cadr exp)) (qq-car-cdr exp)))) (set! qq-lev (-1+ qq-lev)) qq-val)) ((or (eq? (car exp) 'unquote) (eq? (car exp) 'unquote-splicing)) (set! qq-lev (-1+ qq-lev)) (let ((qq-val (if (= qq-lev 0) ; min val ; --> outermost level (if (eq? (car exp) 'unquote-splicing) (cons append-me-sym (%expand-macros (cadr exp))) (%expand-macros (cadr exp))) (qq-car-cdr exp)))) (set! qq-lev (1+ qq-lev)) qq-val)) (else (qq-car-cdr exp))))) ) (let ((expansion (qq l))) (if check-qq-expansion-flag (check-qq-expansion expansion)) ; error on failure expansion)))) (define CHECK-QQ-EXPANSION (lambda (exp) (cond ((vector? exp) (check-qq-expansion (vector->list exp))) ((atom? exp) #f) (else (if (eq? (car exp) append-me-sym) (error "UNQUOTE-SPLICING in unspliceable position" (list 'unquote-splicing (cdr exp))) (or (check-qq-expansion (car exp)) (check-qq-expansion (cdr exp)))))))) (define CHECK-QQ-EXPANSION-FLAG #t) ; do checking (define UNQ-EXPANDER (lambda (l) (error "UNQUOTE outside QUASIQUOTE" l))) (define UNQ-SPL-EXPANDER (lambda (l) (error "UNQUOTE SPLICING outside QUASIQUOTE" l))) ;;; MACROS: must be evaluated with MACRO system in place (compiler-syntax QUASIQUOTE qq-expander) (compiler-syntax UNQUOTE unq-expander) (compiler-syntax UNQUOTE-SPLICING unq-spl-expander) ;;; END dr exp))) (or (check-qq-expansion (car exp)) (check-qq-expansion (cdr exp)))))))) (define CHECK-QQ-EXPANSION-FLAG #t) ; do checking (define UNQ-EXPANDER (lambda (l) (error "UNQUOTE outside QUASIQUOTE" l))) (define UNQ-SPL-EXPANDER (lambda (l) (error "UNQUOTE SPLICING outside QUASIQUOTE" l))) ;;; MACROS: mustsrc/ 5605 4652 212 #include <osbind.h> #include "xscheme.h" #define STRMAX 100 /* maximum length of a string constant */ /* char buf[STRMAX+1] = { 0 }; */ static char buf[200]; #define LBSIZE 200 /* set MWC memory parameters */ long _stksize = 16384; /* stack must be 16K */ /* external variables */ extern LVAL s_unbound,true; extern int errno; extern FILE *tfp; extern char buf[]; /* line buffer variables */ static char lbuf[LBSIZE]; static int lpos[LBSIZE]; static int lindex; static int lcount; static int lposition; /* osinit - initialize */ osinit(banner) char *banner; { printf("\033v%s\n",banner); lposition = 0; lindex = 0; lcount = 0; } /* osfinish - clean up before a return to the operating system */ osfinish() { } /* oserror - print an error message */ oserror(msg) char *msg; { printf("error: %s\n",msg); } /* osrand - return a random number between 0 and n-1 */ int osrand(n) int n; { return (rand() % n); } /* osaopen - open an ascii file */ FILE *osaopen(name,mode) char *name,*mode; { return (fopen(name,mode)); } /* osbopen - open a binary file */ FILE *osbopen(name,mode) char *name,*mode; { char rmode[5]; strcpy(rmode,mode); strcat(rmode,"b"); return (fopen(name,rmode)); } /* osclose - close a file */ int osclose(fp) FILE *fp; { return (fclose(fp)); } /* osagetc - get a character from an ascii file */ int osagetc(fp) FILE *fp; { return (getc(fp)); } /* osaputc - put a character to an ascii file */ int osaputc(ch,fp) int ch; FILE *fp; { return (putc(ch,fp)); } /* osbgetc - get a character from a binary file */ int osbgetc(fp) FILE *fp; { return (getc(fp)); } /* osbputc - put a character to a binary file */ int osbputc(ch,fp) int ch; FILE *fp; { return (putc(ch,fp)); } /* ostgetc - get a character from the terminal */ int ostgetc() { int ch; /* check for a buffered character */ if (lcount--) return (lbuf[lindex++]); /* get an input line */ for (lcount = 0; ; ) switch (ch = xgetc()) { case '\r': lbuf[lcount++] = '\n'; xputc('\r'); xputc('\n'); lposition = 0; if (tfp) for (lindex = 0; lindex < lcount; ++lindex) osaputc(lbuf[lindex],tfp); lindex = 0; lcount--; return (lbuf[lindex++]); case '\010': case '\177': if (lcount) { lcount--; while (lposition > lpos[lcount]) { xputc('\010'); xputc(' '); xputc('\010'); lposition--; } } break; case '\032': xflush(); return (EOF); default: if (ch == '\t' || (ch >= 0x20 && ch < 0x7F)) { lbuf[lcount] = ch; lpos[lcount] = lposition; if (ch == '\t') do { xputc(' '); } while (++lposition & 7); else { xputc(ch); lposition++; } lcount++; } else { xflush(); switch (ch) { case '\002': xlbreak("CTL-b",TRUE); /* control-b */ case '\003': xltoplevel(); /* control-c */ case '\007': xlcleanup(); /* control-g */ case '\020': xlcontinue(); /* control-p */ case '\032': return (EOF); /* control-z */ default: return (ch); } } } } /* ostputc - put a character to the terminal */ ostputc(ch) int ch; { /* check for control characters */ oscheck(); /* output the character */ if (ch == '\n') { xputc('\r'); xputc('\n'); lposition = 0; } else { xputc(ch); lposition++; } /* output the character to the transcript file */ if (tfp) osaputc(ch,tfp); } /* oscheck - check for control characters during execution */ oscheck() { int ch; if (ch = xcheck()) switch (ch) { case '\002': xflush(); xlbreak("BREAK",s_unbound); break; case '\003': xflush(); xltoplevel(); break; } } /* osflush - flush the input line buffer */ osflush() { lindex = lcount = 0; } /* ostell - get the current file position */ long ostell(fp) FILE *fp; { return (ftell(fp)); } /* osseek - set the current file position */ int osseek(fp,offset,whence) FILE *fp; long offset; int whence; { return (fseek(fp,offset,whence)); } /* xflush - flush the input line buffer */ static xflush() { ostputc('\n'); osflush(); } /* xgetc - get a character from the terminal without echo */ static int xgetc() { int ch; while ((ch = Crawio(0xFF)) == 0) ; return (ch & 0xFF); } /* xputc - put a character to the terminal */ static xputc(ch) int ch; { Crawio(ch); } /* xcheck - check for a character */ static int xcheck() { return (Crawio(0xFF)); } /* file name extension table */ char *ext[] = { ".prg",".tos",".ttp",NULL }; /* xsystem - the built-in function 'system' */ LVAL xsystem() { char *str,*p,cmd[100]; int cmdlen,sts,i; /* get the command string */ str = getstring(xlgastring()); xllastarg(); /* get the command name */ for (p = cmd, cmdlen = 0; *str && !isspace(*str); ++cmdlen) *p++ = *str++; *p = '\0'; /* skip spaces between the command name and the arguments */ while (*str && isspace(*str)) ++str; /* make a counted ascii argument list */ for (p = &buf[1], buf[0] = '\0'; *str; ++buf[0]) *p++ = *str++; *p = '\0'; /* try each extension */ for (i = 0; ext[i]; ++i) { strcpy(&cmd[cmdlen],ext[i]); if ((sts = Pexec(0,cmd,buf,"")) != -33) break; } /* return the completion status */ return (cvfixnum((FIXTYPE)sts)); } /* xgetkey - get a key from the keyboard */ LVAL xgetkey() { xllastarg(); return (cvfixnum((FIXTYPE)xgetc())); } /* ossymbols - lookup important symbols */ ossymbols() { } argument list */ for (p = &busrc/osdefs.h 3400 6275 #ifdef MACINTOSH extern LVAL xhidepen(),xshowpen(),xgetpen(),xpensize(),xpenmode(); extern LVAL xpenpat(),xpennormal(),xmoveto(),xmove(),xlineto(),xline(); extern LVAL xshowgraphics(),xhidegraphics(),xcleargraphics(); #endif #ifdef MSDOS extern LVAL xint86(),xinbyte(),xoutbyte(),xsystem(),xgetkey(); #endif #ifdef UNIX extern LVAL xsystem(); #endif ϕ achine specific functions */ #ifdef MACINTOSH { "HIDEPEN", xhidepen }, { "SHOWPEN", xshowpen }, { "GETPEN", xgetpen }, { "PENSIZE", xpensize }, { "PENMODE", xpenmode }, { "PENPAT", xpenpat }, { "PENNORMAL", xpennormal }, { "MOVETO", xmoveto }, { "MOVE", xmove }, { "LINETO", xlineto }, { "LINE", xline }, { "SHOW-GRAPHICS", xshowgraphics }, { "HIDE-GRAPHICS", xhidegraphics }, { "CLEAR-GRAPHICS", xcleargraphics }, #endif #ifdef MSDOS { "INT86", xint86 }, { "INBYTE", xinbyte }, { "OUTBYTE", xoutbyte }, { "SYSTEM", xsystem }, { "GET-KEY", xgetkey }, #endif #ifdef UNIX { "SYSTEM", xsystem }, #endif ENMODE", xpenmode }, { "PENPAT", xpenpat }, { "PENNORMAL", xpennormal }, { "MOVETO", xmoveto }, { "MOVE", xmove }, { "LINETO", xlineto }, { "LINE", xline }, { "SHOW-GRAPHICS", xshowgraphics }, { "HIDE-GRAPHICS", xhidegraphics }, { "CLEAR-GRAPHICS", xcleargraphics }, #endif #ifdef Msrc/makefile.tos 155 CFLAGS= -O -Datarist=1 -I. -I/users/gjh/cross-gcc/include OBJ1 =xscheme.o xsdmem.o xsftab.o xsimage.o xsio.o xsobj.o \ xsprint.o xsread.o xssym.o xsfun1.o xsfun2.o xsmath.o ststuff.o OBJ2=xsinit.o xscom.o xsint.o xscheme: $(OBJ1) $(OBJ2) $(CC) $(CFLAGS) -o xscheme.ttp $(OBJ1) $(OBJ2) -lpml $(OBJ1): xscheme.h $(OBJ2): xscheme.h xsbcode.h ∩π⑧ /* Copyright (c) 1988, by David Michael Betz All Rights Reserved Permission is granted for unrestricted non-commercial use */ #define OP_BRT 0x01 /* branch on true */ #define OP_BRF 0x02 /* branch on false */ #define OP_BR 0x03 /* branch unconditionally */ #define OP_LIT 0x04 /* load literal */ #define OP_GREF 0x05 /* global symbol value */ #define OP_GSET 0x06 /* set global symbol value */ #define OP_EREF 0x09 /* environment variable value */ #define OP_ESET 0x0A /* set environment variable value */ #define OP_SAVE 0x0B /* save a continuation */ #define OP_CALL 0x0C /* call a function */ #define OP_RETURN 0x0D /* return from a function */ #define OP_T 0x0E /* load 'val' with t */ #define OP_NIL 0x0F /* load 'val' with nil */ #define OP_PUSH 0x10 /* push the 'val' register */ #define OP_CLOSE 0x11 /* create a closure */ #define OP_FRAME 0x12 /* create a new enviroment frame */ #define OP_MVARG 0x13 /* move required argument to frame slot */ #define OP_MVOARG 0x14 /* move optional argument to frame slot */ #define OP_MVRARG 0x15 /* build rest argument and move to frame slot */ #define OP_ADROP 0x19 /* drop the rest of the arguments */ #define OP_ALAST 0x1A /* make sure there are no more arguments */ #define OP_DELAY 0x1B /* create a promise */ #define OP_AREF 0x1C /* access a variable in an environment */ #define OP_ASET 0x1D /* set a variable in an environment */ #define OP_ATOM 0x1E /* atom predicate */ #define OP_EQ 0x1F /* eq? predicate */ #define OP_NULL 0x20 /* null? (or not) predicate */ #define OP_CONS 0x21 /* cons */ #define OP_CAR 0x22 /* car */ #define OP_CDR 0x23 /* cdr */ #define OP_SETCAR 0x24 /* set-car! */ #define OP_SETCDR 0x25 /* set-cdr! */ #define OP_ADD 0x40 /* add two numeric expressions */ #define OP_SUB 0x41 /* subtract two numeric expressions */ #define OP_MUL 0x42 /* multiply two numeric expressions */ #define OP_QUO 0x43 /* divide two integer expressions */ #define OP_LSS 0x44 /* less than */ #define OP_EQL 0x45 /* equal to */ #define OP_GTR 0x46 /* greater than */ e OP_CONS 0x21 /* cons */ #define OP_CAR 0x22 /* car */ #define OP_CDR 0x23 /* cdr */ #define OP_SETCAR 0x24 /* set-car! */ #define OP_SETCDR 0x25 /* set-cdr! */ #define OP_ADD 0x40 /* add two numeric expressions */ #define OP_SUB 0x41 /* subtract two numeric expressions */ #define OP_MUL 0x42 /* multiply two numeric expressions */ #define OP_QUO 0x43 /* divide two integer expressions */ #define OP_LSS 0x44 /* less than */ #definsrc/xscheme.c 2 /* Copyright (c) 1988, by David Michael Betz All Rights Reserved Permission is granted for unrestricted non-commercial use */ #include "xscheme.h" /* the program banner */ #define BANNER "XScheme - Version 0.22" /* global variables */ jmp_buf top_level; int clargc; /* command line argument count */ char **clargv; /* array of command line arguments */ /* trace file pointer */ FILE *tfp=NULL; /* external variables */ extern LVAL xlfun,xlenv,xlval; extern LVAL s_stdin,s_stdout,s_stderr,s_unbound; extern int trace; /* main - the main routine */ main(argc,argv) int argc; char *argv[]; { int src,dst; LVAL code; char *p; /* process the arguments */ for (src = dst = 1, clargv = argv, clargc = 1; src < argc; ++src) { /* handle options */ if (argv[src][0] == '-') { for (p = &argv[src][1]; *p != '\0'; ) switch (*p++) { case 't': /* root directory */ trace = TRUE; break; default: usage(); } } /* handle a filename */ else { argv[dst++] = argv[src]; ++clargc; } } /* setup an initialization error handler */ if (setjmp(top_level)) exit(1); /* initialize */ osinit(BANNER); /* restore the default workspace, otherwise create a new one */ if (!xlirestore("xscheme.wks")) xlinitws(5000); /* do the initialization code first */ code = xlenter("*INITIALIZE*"); code = (boundp(code) ? getvalue(code) : NIL); /* trap errors */ if (setjmp(top_level)) { code = xlenter("*TOPLEVEL*"); code = (boundp(code) ? getvalue(code) : NIL); xlfun = xlenv = xlval = NIL; xlsp = xlstktop; } /* execute the main loop */ if (code != NIL) xlexecute(code); wrapup(); } usage() { info("usage: xscheme [-t]\n"); exit(1); } xlload() {} xlcontinue() {} xlbreak() { xltoplevel(); } xlcleanup() {} /* xltoplevel - return to the top level */ xltoplevel() { stdputstr("[ back to top level ]\n"); longjmp(top_level,1); } /* xlfail - report an error */ xlfail(msg) char *msg; { xlerror(msg,s_unbound); } /* xlerror - report an error */ xlerror(msg,arg) char *msg; LVAL arg; { /* display the error message */ errputstr("Error: "); errputstr(msg); errputstr("\n"); /* print the argument on a separate line */ if (arg != s_unbound) { errputstr(" "); errprint(arg); } /* print the function where the error occurred */ errputstr("happened in: "); errprint(xlfun); /* call the handler */ callerrorhandler(); } /* callerrorhandler - call the error handler */ callerrorhandler() { extern jmp_buf bc_dispatch; /* invoke the error handler */ if (xlval = getvalue(xlenter("*ERROR-HANDLER*"))) { oscheck(); /* an opportunity to break out of a bad handler */ check(2); push(xlenv); push(xlfun); xlargc = 2; xlapply(); longjmp(bc_dispatch,1); } /* no handler, just reset back to the top level */ longjmp(top_level,1); } /* xlabort - print an error message and abort */ xlabort(msg) char *msg; { /* display the error message */ errputstr("Abort: "); errputstr(msg); errputstr("\n"); /* print the function where the error occurred */ errputstr("happened in: "); errprint(xlfun); /* reset back to the top level */ oscheck(); /* an opportunity to break out */ longjmp(top_level,1); } /* xlfatal - print a fatal error message and exit */ xlfatal(fmt,a1,a2,a3,a4) char *fmt; { char buf[100]; sprintf(buf,fmt,a1,a2,a3,a4); oserror(buf); exit(1); } /* info - display debugging information */ info(fmt,a1,a2,a3,a4) char *fmt; { char buf[100],*p; sprintf(buf,fmt,a1,a2,a3,a4); for (p = buf; *p != '\0'; ) ostputc(*p++); } /* wrapup - clean up and exit to the operating system */ wrapup() { if (tfp) osclose(tfp); osfinish(); exit(0); } (top_level,1); } /* xlfatal - print a fatal error message and exit */ xlfatal(fmt,a1,a2,a3,a4) char *fmt; { char buf[100]; sprintf(buf,fmt,a1,a2,a3,a4); oserror(buf)src/xscheme.h 1104 6504 /* Copyright (c) 1988, by David Michael Betz All Rights Reserved Permission is granted for unrestricted non-commercial use */ /* system specific definitions */ /* #define _TURBOC_ */ #define UNIX #include <stdio.h> #include <ctype.h> #include <setjmp.h> /* FORWARD type of a forward declaration () */ /* LOCAL type of a local function (static) */ /* AFMT printf format for addresses ("%x") */ /* OFFTYPE number the size of an address (int) */ /* FIXTYPE data type for fixed point numbers (long) */ /* ITYPE fixed point input conversion routine type (long atol()) */ /* ICNV fixed point input conversion routine (atol) */ /* IFMT printf format for fixed point numbers ("%ld") */ /* FLOTYPE data type for floating point numbers (float) */ /* FFMT printf format for floating point numbers (%.15g) */ /* for the Lightspeed C compiler - Macintosh */ #ifdef LSC #define AFMT "%lx" #define OFFTYPE long #define NIL (void *)0 #define MACINTOSH #endif /* for the UNIX System V C compiler */ #ifdef UNIX #endif /* for the Aztec C compiler - Amiga */ #ifdef AZTEC_AMIGA #define AFMT "%lx" #define OFFTYPE long #endif /* for the Mark Williams C compiler - Atari ST */ #ifdef MWC #define AFMT "%lx" #define OFFTYPE long #endif /* for the Microsoft C 5.0 compiler */ #ifdef MSC #define AFMT "%lx" #define OFFTYPE long #define INSEGMENT(n,s) (((OFFTYPE)(n) >> 16) == ((OFFTYPE)(s) >> 16)) #define VCOMPARE(f,s,t) ((LVAL huge *)(f) + (s) <= (LVAL huge *)(t)) /* #define MSDOS -- MSC 5.0 defines this automatically */ #endif /* for the Turbo C compiler */ #ifdef _TURBOC_ #define AFMT "%lx" #define OFFTYPE long #define INSEGMENT(n,s) (((OFFTYPE)(n) >> 16) == ((OFFTYPE)(s) >> 16)) #define VCOMPARE(f,s,t) ((LVAL huge *)(f) + (s) <= (LVAL huge *)(t)) #define MSDOS #endif /* size of each type of memory segment */ #ifndef NSSIZE #define NSSIZE 4000 /* number of nodes per node segment */ #endif #ifndef VSSIZE #define VSSIZE 10000 /* number of LVAL's per vector segment */ #endif /* default important definitions */ #ifndef FORWARD #define FORWARD #endif #ifndef LOCAL #define LOCAL static #endif #ifndef AFMT #define AFMT "%x" #endif #ifndef OFFTYPE #define OFFTYPE int #endif #ifndef FIXTYPE #define FIXTYPE long #endif #ifndef ITYPE #define ITYPE long atol() #endif #ifndef ICNV #define ICNV(n) atol(n) #endif #ifndef IFMT #define IFMT "%ld" #endif #ifndef FLOTYPE #define FLOTYPE double #endif #ifndef FFMT #define FFMT "%.15g" #endif #ifndef SFIXMIN #define SFIXMIN -1048576 #define SFIXMAX 1048575 #endif #ifndef INSEGMENT #define INSEGMENT(n,s) ((n) >= &(s)->ns_data[0] \ && (n) < &(s)->ns_data[0] + (s)->ns_size) #endif #ifndef VCOMPARE #define VCOMPARE(f,s,t) ((f) + (s) <= (t)) #endif /* useful definitions */ #define TRUE 1 #define FALSE 0 #ifndef NIL #define NIL (LVAL)0 #endif /* program limits */ #define STRMAX 100 /* maximum length of a string constant */ #define HSIZE 199 /* symbol hash table size */ #define SAMPLE 100 /* control character sample rate */ /* stack manipulation macros */ #define check(n) { if (xlsp - (n) < xlstkbase) xlstkover(); } #define cpush(v) { if (xlsp > xlstkbase) push(v); else xlstkover(); } #define push(v) (*--xlsp = (v)) #define pop() (*xlsp++) #define top() (*xlsp) #define settop(v) (*xlsp = (v)) #define drop(n) (xlsp += (n)) /* argument list parsing macros */ #define xlgetarg() (testarg(nextarg())) #define xllastarg() {if (xlargc != 0) xltoomany();} #define xlpoprest() {xlsp += xlargc;} #define testarg(e) (moreargs() ? (e) : xltoofew()) #define typearg(tp) (tp(*xlsp) ? nextarg() : xlbadtype(*xlsp)) #define nextarg() (--xlargc, *xlsp++) #define moreargs() (xlargc > 0) /* macros to get arguments of a particular type */ #define xlgacons() (testarg(typearg(consp))) #define xlgalist() (testarg(typearg(listp))) #define xlgasymbol() (testarg(typearg(symbolp))) #define xlgastring() (testarg(typearg(stringp))) #define xlgaobject() (testarg(typearg(objectp))) #define xlgafixnum() (testarg(typearg(fixp))) #define xlganumber() (testarg(typearg(numberp))) #define xlgachar() (testarg(typearg(charp))) #define xlgavector() (testarg(typearg(vectorp))) #define xlgaport() (testarg(typearg(portp))) #define xlgaiport() (testarg(typearg(iportp))) #define xlgaoport() (testarg(typearg(oportp))) #define xlgaclosure() (testarg(typearg(closurep))) #define xlgaenv() (testarg(typearg(envp))) /* node types */ #define FREE 0 #define CONS 1 #define SYMBOL 2 #define FIXNUM 3 #define FLONUM 4 #define STRING 5 #define OBJECT 6 #define PORT 7 #define VECTOR 8 #define CLOSURE 9 #define METHOD 10 #define CODE 11 #define SUBR 12 #define XSUBR 13 #define CSUBR 14 #define CONTINUATION 15 #define CHAR 16 #define PROMISE 17 #define ENV 18 /* node flags */ #define MARK 1 #define LEFT 2 /* port flags */ #define PF_INPUT 1 #define PF_OUTPUT 2 #define PF_BINARY 4 /* new node access macros */ #define ntype(x) ((OFFTYPE)(x) & 1 ? FIXNUM : (x)->n_type) /* macro to determine if a non-nil value is a pointer */ #define ispointer(x) (((OFFTYPE)(x) & 1) == 0) /* type predicates */ #define atom(x) ((x) == NIL || ntype(x) != CONS) #define null(x) ((x) == NIL) #define listp(x) ((x) == NIL || ntype(x) == CONS) #define numberp(x) ((x) && ntype(x) == FIXNUM || ntype(x) == FLONUM) #define boundp(x) (getvalue(x) != s_unbound) #define iportp(x) (portp(x) && (getpflags(x) & PF_INPUT) != 0) #define oportp(x) (portp(x) && (getpflags(x) & PF_OUTPUT) != 0) /* basic type predicates */ #define consp(x) ((x) && ntype(x) == CONS) #define stringp(x) ((x) && ntype(x) == STRING) #define symbolp(x) ((x) && ntype(x) == SYMBOL) #define portp(x) ((x) && ntype(x) == PORT) #define objectp(x) ((x) && ntype(x) == OBJECT) #define fixp(x) ((x) && ntype(x) == FIXNUM) #define floatp(x) ((x) && ntype(x) == FLONUM) #define vectorp(x) ((x) && ntype(x) == VECTOR) #define closurep(x) ((x) && ntype(x) == CLOSURE) #define codep(x) ((x) && ntype(x) == CODE) #define methodp(x) ((x) && ntype(x) == METHOD) #define subrp(x) ((x) && ntype(x) == SUBR) #define xsubrp(x) ((x) && ntype(x) == XSUBR) #define charp(x) ((x) && ntype(x) == CHAR) #define promisep(x) ((x) && ntype(x) == PROMISE) #define envp(x) ((x) && ntype(x) == ENV) #define booleanp(x) ((x) == NIL || ntype(x) == BOOLEAN) /* vector update macro This is necessary because the memory pointed to by the n_vdata field of a vector object can move during a garbage collection. This macro guarantees that evaluation happens in the right order. */ #define vupdate(x,i,v) { LVAL vutmp=(v); (x)->n_vdata[i] = vutmp; } /* cons access macros */ #define car(x) ((x)->n_car) #define cdr(x) ((x)->n_cdr) #define rplaca(x,y) ((x)->n_car = (y)) #define rplacd(x,y) ((x)->n_cdr = (y)) /* symbol access macros */ #define getvalue(x) ((x)->n_vdata[0]) #define setvalue(x,v) vupdate(x,0,v) #define getpname(x) ((x)->n_vdata[1]) #define setpname(x,v) vupdate(x,1,v) #define getplist(x) ((x)->n_vdata[2]) #define setplist(x,v) vupdate(x,2,v) #define SYMSIZE 3 /* vector access macros */ #define getsize(x) ((x)->n_vsize) #define getelement(x,i) ((x)->n_vdata[i]) #define setelement(x,i,v) vupdate(x,i,v) /* object access macros */ #define getclass(x) ((x)->n_vdata[1]) #define setclass(x,v) vupdate(x,1,v) #define getivar(x,i) ((x)->n_vdata[i]) #define setivar(x,i,v) vupdate(x,i,v) /* promise access macros */ #define getpproc(x) ((x)->n_car) #define setpproc(x,v) ((x)->n_car = (v)) #define getpvalue(x) ((x)->n_cdr) #define setpvalue(x,v) ((x)->n_cdr = (v)) /* closure access macros */ #define getcode(x) ((x)->n_car) #define getenv(x) ((x)->n_cdr) /* code access macros */ #define getbcode(x) ((x)->n_vdata[0]) #define setbcode(x,v) vupdate(x,0,v) #define getcname(x) ((x)->n_vdata[1]) #define setcname(x,v) vupdate(x,1,v) #define getvnames(x) ((x)->n_vdata[2]) #define setvnames(x,v) vupdate(x,2,v) #define FIRSTLIT 3 /* fixnum/flonum/character access macros */ #define getfixnum(x) ((OFFTYPE)(x) & 1 ? getsfixnum(x) : (x)->n_int) #define getflonum(x) ((x)->n_flonum) #define getchcode(x) ((x)->n_chcode) /* small fixnum access macros */ #define cvsfixnum(x) ((LVAL)(((OFFTYPE)x << 1) | 1)) #define getsfixnum(x) ((FIXTYPE)((OFFTYPE)(x) >> 1)) /* string access macros */ #define getstring(x) ((unsigned char *)(x)->n_vdata) #define getslength(x) ((x)->n_vsize) /* iport/oport access macros */ #define getfile(x) ((x)->n_fp) #define setfile(x,v) ((x)->n_fp = (v)) #define getsavech(x) ((x)->n_savech) #define setsavech(x,v) ((x)->n_savech = (v)) #define getpflags(x) ((x)->n_pflags) #define setpflags(x,v) ((x)->n_pflags = (v)) /* subr access macros */ #define getsubr(x) ((x)->n_subr) #define getoffset(x) ((x)->n_offset) /* list node */ #define n_car n_info.n_xlist.xl_car #define n_cdr n_info.n_xlist.xl_cdr /* integer node */ #define n_int n_info.n_xint.xi_int /* flonum node */ #define n_flonum n_info.n_xflonum.xf_flonum /* character node */ #define n_chcode n_info.n_xchar.xc_chcode /* string node */ #define n_str n_info.n_xstr.xst_str #define n_strlen n_info.n_xstr.xst_length /* file pointer node */ #define n_fp n_info.n_xfptr.xf_fp #define n_savech n_info.n_xfptr.xf_savech #define n_pflags n_info.n_xfptr.xf_pflags /* vector/object node */ #define n_vsize n_info.n_xvect.xv_size #define n_vdata n_info.n_xvect.xv_data /* subr node */ #define n_subr n_info.n_xsubr.xs_subr #define n_offset n_info.n_xsubr.xs_offset /* node structure */ typedef struct node { char n_type; /* type of node */ char n_flags; /* flag bits */ union ninfo { /* value */ struct xlist { /* list node (cons) */ struct node *xl_car; /* the car pointer */ struct node *xl_cdr; /* the cdr pointer */ } n_xlist; struct xint { /* integer node */ FIXTYPE xi_int; /* integer value */ } n_xint; struct xflonum { /* flonum node */ FLOTYPE xf_flonum; /* flonum value */ } n_xflonum; struct xchar { /* character node */ int xc_chcode; /* character code */ } n_xchar; struct xstr { /* string node */ int xst_length; /* string length */ unsigned char *xst_str; /* string pointer */ } n_xstr; struct xfptr { /* file pointer node */ FILE *xf_fp; /* the file pointer */ short xf_savech; /* lookahead character for input files */ short xf_pflags; /* port flags */ } n_xfptr; struct xvect { /* vector node */ int xv_size; /* vector size */ struct node **xv_data; /* vector data */ } n_xvect; struct xsubr { /* subr/fsubr node */ struct node *(*xs_subr)(); /* function pointer */ int xs_offset; /* offset into funtab */ } n_xsubr; } n_info; } NODE,*LVAL; /* memory allocator definitions */ /* macros to compute the size of a segment */ #define nsegsize(n) (sizeof(NSEGMENT)+((n)-1)*sizeof(struct node)) #define vsegsize(n) (sizeof(VSEGMENT)+((n)-1)*sizeof(LVAL)) /* macro to convert a byte size to a word size */ #define btow_size(n) (((n) + sizeof(LVAL) - 1) / sizeof(LVAL)) /* node segment structure */ typedef struct nsegment { struct nsegment *ns_next; /* next node segment */ unsigned int ns_size; /* number of nodes in this segment */ struct node ns_data[1]; /* segment data */ } NSEGMENT; /* vector segment structure */ typedef struct vsegment { struct vsegment *vs_next; /* next vector segment */ LVAL *vs_free; /* next free location in this segment */ LVAL *vs_top; /* top of segment (plus one) */ LVAL vs_data[1]; /* segment data */ } VSEGMENT; /* function definition structure */ typedef struct { char *fd_name; /* function name */ LVAL (*fd_subr)(); /* function entry point */ } FUNDEF; /* external variables */ extern LVAL *xlstkbase; /* base of value stack */ extern LVAL *xlstktop; /* top of value stack */ extern LVAL *xlsp; /* value stack pointer */ extern int xlargc; /* argument count for current call */ /* external routine declarations */ extern LVAL cons(); /* (cons x y) */ extern LVAL xlenter(); /* enter a symbol */ extern LVAL xlgetprop(); /* get the value of a property */ extern LVAL cvsymbol(); /* convert a string to a symbol */ extern LVAL cvstring(); /* convert a string */ extern LVAL cvfixnum(); /* convert a fixnum */ extern LVAL cvflonum(); /* convert a flonum */ extern LVAL cvchar(); /* convert a character */ extern LVAL cvclosure(); /* convert code and an env to a closure */ extern LVAL cvmethod(); /* convert code and an env to a method */ extern LVAL cvsubr(); /* convert a function into a subr */ extern LVAL cvport(); /* convert a file pointer to an input port */ extern LVAL cvpromise(); /* convert a procedure to a promise */ extern LVAL newstring(); /* create a new string */ extern LVAL newobject(); /* create a new object */ extern LVAL newvector(); /* create a new vector */ extern LVAL newcode(); /* create a new code object */ extern LVAL newcontinuation(); /* create a new continuation object */ extern LVAL newframe(); /* create a new environment frame */ extern LVAL newnode(); /* create a new node */ extern LVAL xltoofew(); /* report "too few arguments" */ extern LVAL xlbadtype(); /* report "wrong argument type" */ extern LVAL curinput(); /* get the current input port */ extern LVAL curoutput(); /* get the current output port */ src/xscom.c /* Copyright (c) 1988, by David Michael Betz All Rights Reserved Permission is granted for unrestricted non-commercial use */ #include "xscheme.h" #include "xsbcode.h" /* size of code buffer */ #define CMAX 4000 /* continuation types */ #define C_RETURN -1 #define C_NEXT -2 /* macro to check for a lambda list keyword */ #define lambdakey(x) ((x) == lk_optional || (x) == lk_rest) /* external variables */ extern LVAL lk_optional,lk_rest,true_lval; /* BCB global rename true ==> true_lval */ /* local variables */ static LVAL info; /* compiler info */ /* code buffer */ static unsigned char cbuff[CMAX]; /* base of code buffer */ static int cbase; /* base for current function */ static int cptr; /* code buffer pointer */ /* forward declarations */ int do_define(),do_set(),do_quote(),do_lambda(),do_delay(); int do_let(),do_letrec(),do_letstar(),do_cond(),do_and(),do_or(); int do_if(),do_begin(),do_while(),do_access(); LVAL make_code_object(); /* integrable function table */ typedef struct { char *nt_name; int nt_code,nt_args; } NTDEF; static NTDEF *nptr,ntab[] = { "ATOM", OP_ATOM, 1, "EQ?", OP_EQ, 2, "NULL?", OP_NULL, 1, "NOT", OP_NULL, 1, "CONS", OP_CONS, 2, "CAR", OP_CAR, 1, "CDR", OP_CDR, 1, "SET-CAR!", OP_SETCAR, 2, "SET-CDR!", OP_SETCDR, 2, "+", OP_ADD, -2, "-", OP_SUB, -2, "*", OP_MUL, -2, "QUOTIENT", OP_QUO, -2, "<", OP_LSS, -2, "=", OP_EQL, -2, ">", OP_GTR, -2, 0 }; /* special form table */ typedef struct { char *ft_name; int (*ft_fcn)(); } FTDEF; static FTDEF ftab[] = { "QUOTE", do_quote, "LAMBDA", do_lambda, "DELAY", do_delay, "LET", do_let, "LET*", do_letstar, "LETREC", do_letrec, "DEFINE", do_define, "SET!", do_set, "IF", do_if, "COND", do_cond, "BEGIN", do_begin, "SEQUENCE", do_begin, "AND", do_and, "OR", do_or, "WHILE", do_while, "ACCESS", do_access, 0 }; /* xlcompile - compile an expression */ LVAL xlcompile(expr,ctenv) LVAL expr,ctenv; { /* initialize the compile time environment */ info = cons(NIL,NIL); cpush(info); rplaca(info,newframe(ctenv,1)); rplacd(info,cons(NIL,NIL)); /* setup the base of the code for this function */ cbase = cptr = 0; /* setup the entry code */ putcbyte(OP_FRAME); putcbyte(1); /* compile the expression */ do_expr(expr,C_RETURN); /* build the code object */ settop(make_code_object(NIL)); return (pop()); } /* xlfunction - compile a function */ LVAL xlfunction(fun,fargs,body,ctenv) LVAL fun,fargs,body,ctenv; { /* initialize the compile time environment */ info = cons(NIL,NIL); cpush(info); rplaca(info,newframe(ctenv,1)); rplacd(info,cons(NIL,NIL)); /* setup the base of the code for this function */ cbase = cptr = 0; /* compile the lambda list and the function body */ parse_lambda_list(fargs,body); do_begin(body,C_RETURN); /* build the code object */ settop(make_code_object(fun)); return (pop()); } /* do_expr - compile an expression */ LOCAL do_expr(expr,cont) LVAL expr; int cont; { LVAL fun; if (consp(expr)) { fun = car(expr); if (!symbolp(fun) || (!in_ntab(expr,cont) && !in_ftab(expr,cont))) do_call(expr,cont); } else if (symbolp(expr)) do_identifier(expr,cont); else do_literal(expr,cont); } /* in_ntab - check for a function in ntab */ LOCAL int in_ntab(expr,cont) LVAL expr; int cont; { unsigned char *pname; pname = getstring(getpname(car(expr))); for (nptr = ntab; nptr->nt_name; ++nptr) if (strcmp(pname,nptr->nt_name) == 0) { do_nary(nptr->nt_code,nptr->nt_args,expr,cont); return (TRUE); } return (FALSE); } /* in_ftab - check for a function in ftab */ LOCAL int in_ftab(expr,cont) LVAL expr; int cont; { unsigned char *pname; FTDEF *fptr; pname = getstring(getpname(car(expr))); for (fptr = ftab; fptr->ft_name; ++fptr) if (strcmp(pname,fptr->ft_name) == 0) { (*fptr->ft_fcn)(cdr(expr),cont); return (TRUE); } return (FALSE); } /* do_define - handle the (DEFINE ... ) expression */ LOCAL do_define(form,cont) LVAL form; int cont; { if (atom(form)) xlerror("expecting symbol or function template",form); define1(car(form),cdr(form),cont); } /* define1 - helper routine for do_define */ LOCAL define1(list,body,cont) LVAL list,body; int cont; { LVAL fargs; int off; /* handle nested definitions */ if (consp(list)) { cpush(cons(xlenter("LAMBDA"),NIL)); /* (LAMBDA) */ rplacd(top(),cons(cdr(list),NIL)); /* (LAMBDA args) */ rplacd(cdr(top()),body); /* (LAMBDA args body) */ settop(cons(top(),NIL)); /* ((LAMBDA args body)) */ define1(car(list),top(),cont); drop(1); } /* compile procedure definitions */ else { /* make sure it's a symbol */ if (!symbolp(list)) xlerror("expecting a symbol",list); /* check for a procedure definition */ if (consp(body) && consp(car(body)) && car(car(body)) == xlenter("LAMBDA")) { fargs = car(cdr(car(body))); body = cdr(cdr(car(body))); cd_fundefinition(list,fargs,body); } /* compile the value expression or procedure body */ else do_begin(body,C_NEXT); /* define the variable value */ if (findcvariable(list,&off)) cd_evariable(OP_ESET,0,off); else cd_variable(OP_GSET,list); do_literal(list,cont); } } /* do_set - compile the (SET! ... ) expression */ LOCAL do_set(form,cont) LVAL form; int cont; { if (atom(form)) xlerror("expecting symbol or ACCESS form",form); else if (symbolp(car(form))) do_setvar(form,cont); else if (consp(car(form))) do_setaccess(form,cont); else xlerror("expecting symbol or ACCESS form",form); } /* do_setvar - compile the (SET! var value) expression */ LOCAL do_setvar(form,cont) LVAL form; int cont; { int lev,off; LVAL sym; /* get the variable name */ sym = car(form); /* compile the value expression */ form = cdr(form); if (atom(form)) xlerror("expecting value expression",form); do_expr(car(form),C_NEXT); /* set the variable value */ if (findvariable(sym,&lev,&off)) cd_evariable(OP_ESET,lev,off); else cd_variable(OP_GSET,sym); do_continuation(cont); } /* do_quote - compile the (QUOTE ... ) expression */ LOCAL do_quote(form,cont) LVAL form; int cont; { if (atom(form)) xlerror("expecting quoted expression",form); do_literal(car(form),cont); } /* do_lambda - compile the (LAMBDA ... ) expression */ LOCAL do_lambda(form,cont) LVAL form; int cont; { if (atom(form)) xlerror("expecting argument list",form); cd_fundefinition(NIL,car(form),cdr(form)); do_continuation(cont); } /* cd_fundefinition - compile the function */ LOCAL cd_fundefinition(fun,fargs,body) LVAL fun,fargs,body; { int oldcbase; /* establish a new environment frame */ oldcbase = add_level(); /* compile the lambda list and the function body */ parse_lambda_list(fargs,body); do_begin(body,C_RETURN); /* build the code object */ cpush(make_code_object(fun)); /* restore the previous environment */ remove_level(oldcbase); /* compile code to create a closure */ do_literal(pop(),C_NEXT); putcbyte(OP_CLOSE); } /* parse_lambda_list - parse the formal argument list */ LOCAL parse_lambda_list(fargs,body) LVAL fargs,body; { LVAL arg,restarg,new,last; int frame,slotn; /* setup the entry code */ putcbyte(OP_FRAME); frame = putcbyte(0); /* initialize the argument name list and slot number */ restarg = last = NIL; slotn = 1; /* handle each required argument */ while (consp(fargs) && (arg = car(fargs)) && !lambdakey(arg)) { /* make sure the argument is a symbol */ if (!symbolp(arg)) xlerror("variable must be a symbol",arg); /* add the argument name to the name list */ new = cons(arg,NIL); if (last) rplacd(last,new); else setelement(car(car(info)),0,new); last = new; /* generate an instruction to move the argument into the frame */ putcbyte(OP_MVARG); putcbyte(slotn++); /* move the formal argument list pointer ahead */ fargs = cdr(fargs); } /* check for the '#!optional' argument */ if (consp(fargs) && car(fargs) == lk_optional) { fargs = cdr(fargs); /* handle each optional argument */ while (consp(fargs) && (arg = car(fargs)) && !lambdakey(arg)) { /* make sure the argument is a symbol */ if (!symbolp(arg)) xlerror("#!optional variable must be a symbol",arg); /* add the argument name to the name list */ new = cons(arg,NIL); if (last) rplacd(last,new); else setelement(car(car(info)),0,new); last = new; /* move the argument into the frame */ putcbyte(OP_MVOARG); putcbyte(slotn++); /* move the formal argument list pointer ahead */ fargs = cdr(fargs); } } /* check for the '#!rest' argument */ if (consp(fargs) && car(fargs) == lk_rest) { fargs = cdr(fargs); /* handle the rest argument */ if (consp(fargs) && (restarg = car(fargs)) && !lambdakey(restarg)) { /* make sure the argument is a symbol */ if (!symbolp(restarg)) xlerror("#!rest variable must be a symbol",restarg); /* add the argument name to the name list */ new = cons(restarg,NIL); if (last) rplacd(last,new); else setelement(car(car(info)),0,new); last = new; /* make the #!rest argument list */ putcbyte(OP_MVRARG); putcbyte(slotn++); /* move the formal argument list pointer ahead */ fargs = cdr(fargs); } else xlerror("expecting the #!rest variable"); } /* check for the a dotted tail */ if (restarg == NIL && symbolp(fargs)) { restarg = fargs; /* add the argument name to the name list */ new = cons(restarg,NIL); if (last) rplacd(last,new); else setelement(car(car(info)),0,new); last = new; /* make the #!rest argument list */ putcbyte(OP_MVRARG); putcbyte(slotn++); fargs = NIL; } /* check for the end of the argument list */ if (fargs != NIL) xlerror("bad argument list tail",fargs); /* make sure the user didn't supply too many arguments */ if (restarg == NIL) putcbyte(OP_ALAST); /* scan the body for internal definitions */ slotn += find_internal_definitions(body,last); /* fixup the frame instruction */ cbuff[cbase+frame] = slotn; } /* find_internal_definitions - find internal definitions */ LOCAL int find_internal_definitions(body,last) LVAL body,last; { LVAL define,sym,new; int n=0; /* look for all (define...) forms */ for (define = xlenter("DEFINE"); consp(body); body = cdr(body)) if (consp(car(body)) && car(car(body)) == define) { sym = cdr(car(body)); /* the rest of the (define...) form */ if (consp(sym)) { /* make sure there is a second subform */ sym = car(sym); /* get the second subform */ while (consp(sym))/* check for a procedure definition */ sym = car(sym); if (symbolp(sym)) { new = cons(sym,NIL); if (last) rplacd(last,new); else setelement(car(car(info)),0,new); last = new; ++n; } } } return (n); } /* do_delay - compile the (DELAY ... ) expression */ LOCAL do_delay(form,cont) LVAL form; int cont; { int oldcbase; /* check argument list */ if (atom(form)) xlerror("expecting delay expression",form); /* establish a new environment frame */ oldcbase = add_level(); /* setup the entry code */ putcbyte(OP_FRAME); putcbyte(1); /* compile the expression */ do_expr(car(form),C_RETURN); /* build the code object */ cpush(make_code_object(NIL)); /* restore the previous environment */ remove_level(oldcbase); /* compile code to create a closure */ do_literal(pop(),C_NEXT); putcbyte(OP_DELAY); do_continuation(cont); } /* do_let - compile the (LET ... ) expression */ LOCAL do_let(form,cont) LVAL form; int cont; { /* handle named let */ if (consp(form) && symbolp(car(form))) do_named_let(form,cont); /* handle unnamed let */ else cd_let(NIL,form,cont); } /* do_named_let - compile the (LET name ... ) expression */ LOCAL do_named_let(form,cont) LVAL form; int cont; { int oldcbase,nxt; /* save a continuation */ if (cont != C_RETURN) { putcbyte(OP_SAVE); nxt = putcword(0); } /* establish a new environment frame */ oldcbase = add_level(); setelement(car(car(info)),0,cons(car(form),NIL)); /* setup the entry code */ putcbyte(OP_FRAME); putcbyte(2); /* compile the let expression */ cd_let(car(form),cdr(form),C_RETURN); /* build the code object */ cpush(make_code_object(NIL)); /* restore the previous environment */ remove_level(oldcbase); /* compile code to create a closure */ do_literal(pop(),C_NEXT); putcbyte(OP_CLOSE); /* apply the function */ putcbyte(OP_CALL); putcbyte(1); /* target for the continuation */ if (cont != C_RETURN) fixup(nxt); } /* cd_let - code a let expression */ LOCAL cd_let(name,form,cont) LVAL name,form; int cont; { int oldcbase,nxt,lev,off,n; /* make sure there is a binding list */ if (atom(form) || !listp(car(form))) xlerror("expecting binding list",form); /* save a continuation */ if (cont != C_RETURN) { putcbyte(OP_SAVE); nxt = putcword(0); } /* push the initialization expressions */ n = push_init_expressions(car(form)); /* establish a new environment frame */ oldcbase = add_level(); /* compile the binding list */ parse_let_variables(car(form),cdr(form)); /* compile the body of the let/letrec */ do_begin(cdr(form),C_RETURN); /* build the code object */ cpush(make_code_object(NIL)); /* restore the previous environment */ remove_level(oldcbase); /* compile code to create a closure */ do_literal(pop(),C_NEXT); putcbyte(OP_CLOSE); /* store the procedure */ if (name && findvariable(name,&lev,&off)) cd_evariable(OP_ESET,lev,off); /* apply the function */ putcbyte(OP_CALL); putcbyte(n); /* target for the continuation */ if (cont != C_RETURN) fixup(nxt); } /* do_letrec - compile the (LETREC ... ) expression */ LOCAL do_letrec(form,cont) LVAL form; int cont; { int oldcbase,nxt,n; /* make sure there is a binding list */ if (atom(form) || !listp(car(form))) xlerror("expecting binding list",form); /* save a continuation */ if (cont != C_RETURN) { putcbyte(OP_SAVE); nxt = putcword(0); } /* push the initialization expressions */ n = push_dummy_values(car(form)); /* establish a new environment frame */ oldcbase = add_level(); /* compile the binding list */ parse_let_variables(car(form),cdr(form)); /* compile instructions to set the bound variables */ set_bound_variables(car(form)); /* compile the body of the let/letrec */ do_begin(cdr(form),C_RETURN); /* build the code object */ cpush(make_code_object(NIL)); /* restore the previous environment */ remove_level(oldcbase); /* compile code to create a closure */ do_literal(pop(),C_NEXT); putcbyte(OP_CLOSE); /* apply the function */ putcbyte(OP_CALL); putcbyte(n); /* target for the continuation */ if (cont != C_RETURN) fixup(nxt); } /* do_letstar - compile the (LET* ... ) expression */ LOCAL do_letstar(form,cont) LVAL form; int cont; { int nxt; /* make sure there is a binding list */ if (atom(form) || !listp(car(form))) xlerror("expecting binding list",form); /* handle the case where there are bindings */ if (consp(car(form))) { /* save a continuation */ if (cont != C_RETURN) { putcbyte(OP_SAVE); nxt = putcword(0); } /* build the nested lambda expressions */ letstar1(car(form),cdr(form)); /* target for the continuation */ if (cont != C_RETURN) fixup(nxt); } /* handle the case where there are no bindings */ else do_begin(cdr(form),cont); } /* letstar1 - helper routine for let* */ LOCAL letstar1(blist,body) LVAL blist,body; { int oldcbase,n; /* push the next initialization expressions */ cpush(cons(car(blist),NIL)); n = push_init_expressions(top()); /* establish a new environment frame */ oldcbase = add_level(); /* handle the case where there are more bindings */ if (consp(cdr(blist))) { parse_let_variables(top(),NIL); letstar1(cdr(blist),body); } /* handle the last binding */ else { parse_let_variables(top(),body); do_begin(body,C_RETURN); } /* build the code object */ settop(make_code_object(NIL)); /* restore the previous environment */ remove_level(oldcbase); /* compile code to create a closure */ do_literal(pop(),C_NEXT); putcbyte(OP_CLOSE); /* apply the function */ putcbyte(OP_CALL); putcbyte(n); } /* push_dummy_values - push dummy values for a 'letrec' expression */ LOCAL int push_dummy_values(blist) LVAL blist; { int n=0; if (consp(blist)) { putcbyte(OP_NIL); for (; consp(blist); blist = cdr(blist), ++n) putcbyte(OP_PUSH); } return (n); } /* push_init_expressions - push init expressions for a 'let' expression */ LOCAL int push_init_expressions(blist) LVAL blist; { int n; if (consp(blist)) { n = push_init_expressions(cdr(blist)); if (consp(car(blist)) && consp(cdr(car(blist)))) do_expr(car(cdr(car(blist))),C_NEXT); else putcbyte(OP_NIL); putcbyte(OP_PUSH); return (n+1); } return (0); } /* parse_let_variables - parse the binding list */ LOCAL parse_let_variables(blist,body) LVAL blist,body; { LVAL arg,new,last; int frame,slotn; /* setup the entry code */ putcbyte(OP_FRAME); frame = putcbyte(0); /* initialize the argument name list and slot number */ last = NIL; slotn = 1; /* handle each required argument */ while (consp(blist) && (arg = car(blist))) { /* make sure the argument is a symbol */ if (symbolp(arg)) new = cons(arg,NIL); else if (consp(arg) && symbolp(car(arg))) new = cons(car(arg),NIL); else xlerror("invalid binding",arg); /* add the argument name to the name list */ if (last) rplacd(last,new); else setelement(car(car(info)),0,new); last = new; /* generate an instruction to move the argument into the frame */ putcbyte(OP_MVARG); putcbyte(slotn++); /* move the formal argument list pointer ahead */ blist = cdr(blist); } putcbyte(OP_ALAST); /* scan the body for internal definitions */ slotn += find_internal_definitions(body,last); /* fixup the frame instruction */ cbuff[cbase+frame] = slotn; } /* set_bound_variables - set bound variables in a 'letrec' expression */ LOCAL set_bound_variables(blist) LVAL blist; { int lev,off; for (; consp(blist); blist = cdr(blist)) { if (consp(car(blist)) && consp(cdr(car(blist)))) { do_expr(car(cdr(car(blist))),C_NEXT); if (findvariable(car(car(blist)),&lev,&off)) cd_evariable(OP_ESET,lev,off); else xlerror("compiler error -- can't find",car(car(blist))); } } } /* make_code_object - build a code object */ LOCAL LVAL make_code_object(fun) LVAL fun; { unsigned char *cp; LVAL code,p; int i; /* create a code object */ code = newcode(FIRSTLIT + length(car(cdr(info)))); cpush(code); setbcode(code,newstring(cptr - cbase)); setcname(code,fun); /* function name */ setvnames(code,getelement(car(car(info)),0));/* lambda list variables */ /* copy the literals into the code object */ for (i = FIRSTLIT, p = car(cdr(info)); consp(p); p = cdr(p), ++i) setelement(code,i,car(p)); /* copy the byte codes */ for (i = cbase, cp = getstring(getbcode(code)); i < cptr; ) *cp++ = cbuff[i++]; /* return the new code object */ return (pop()); } /* do_cond - compile the (COND ... ) expression */ LOCAL do_cond(form,cont) LVAL form; int cont; { int nxt,end; if (consp(form)) { for (end = 0; consp(form); form = cdr(form)) { if (atom(car(form))) xlerror("expecting a cond clause",form); do_expr(car(car(form)),C_NEXT); putcbyte(OP_BRF); nxt = putcword(0); if (cdr(car(form))) do_begin(cdr(car(form)),cont); else do_continuation(cont); if (cont == C_NEXT) { putcbyte(OP_BR); end = putcword(end); } fixup(nxt); } fixup(end); } else putcbyte(OP_NIL); do_continuation(cont); } /* do_and - compile the (AND ... ) expression */ LOCAL do_and(form,cont) LVAL form; int cont; { int end; if (consp(form)) { for (end = 0; consp(form); form = cdr(form)) { if (cdr(form)) { do_expr(car(form),C_NEXT); putcbyte(OP_BRF); end = putcword(end); } else do_expr(car(form),cont); } fixup(end); } else putcbyte(OP_T); do_continuation(cont); } /* do_or - compile the (OR ... ) expression */ LOCAL do_or(form,cont) LVAL form; int cont; { int end; if (consp(form)) { for (end = 0; consp(form); form = cdr(form)) { if (cdr(form)) { do_expr(car(form),C_NEXT); putcbyte(OP_BRT); end = putcword(end); } else do_expr(car(form),cont); } fixup(end); } else putcbyte(OP_NIL); do_continuation(cont); } /* do_if - compile the (IF ... ) expression */ LOCAL do_if(form,cont) LVAL form; int cont; { int nxt,end; /* compile the test expression */ if (atom(form)) xlerror("expecting test expression",form); do_expr(car(form),C_NEXT); /* skip around the 'then' clause if the expression is false */ putcbyte(OP_BRF); nxt = putcword(0); /* skip to the 'then' clause */ form = cdr(form); if (atom(form)) xlerror("expecting then clause",form); /* compile the 'then' and 'else' clauses */ if (consp(cdr(form))) { if (cont == C_NEXT) { do_expr(car(form),C_NEXT); putcbyte(OP_BR); end = putcword(0); } else { do_expr(car(form),cont); end = -1; } fixup(nxt); do_expr(car(cdr(form)),cont); nxt = end; } /* compile just a 'then' clause */ else do_expr(car(form),cont); /* handle the end of the statement */ if (nxt >= 0) { fixup(nxt); do_continuation(cont); } } /* do_begin - compile the (BEGIN ... ) expression */ LOCAL do_begin(form,cont) LVAL form; int cont; { if (consp(form)) for (; consp(form); form = cdr(form)) if (consp(cdr(form))) do_expr(car(form),C_NEXT); else do_expr(car(form),cont); else { putcbyte(OP_NIL); do_continuation(cont); } } /* do_while - compile the (WHILE ... ) expression */ LOCAL do_while(form,cont) LVAL form; int cont; { int loop,nxt; /* make sure there is a test expression */ if (atom(form)) xlerror("expecting test expression",form); /* skip around the 'body' to the test expression */ putcbyte(OP_BR); nxt = putcword(0); /* compile the loop body */ loop = cptr - cbase; do_begin(cdr(form),C_NEXT); /* label for the first iteration */ fixup(nxt); /* compile the test expression */ nxt = cptr - cbase; do_expr(car(form),C_NEXT); /* skip around the 'body' if the expression is false */ putcbyte(OP_BRT); putcword(loop); /* compile the continuation */ do_continuation(cont); } /* do_access - compile the (ACCESS var env) expression */ LOCAL do_access(form,cont) LVAL form; int cont; { LVAL sym; /* get the variable name */ if (atom(form) || !symbolp(car(form))) xlerror("expecting symbol",form); sym = car(form); /* compile the environment expression */ form = cdr(form); if (atom(form)) xlerror("expecting environment expression",form); do_expr(car(form),C_NEXT); /* get the variable value */ cd_variable(OP_AREF,sym); do_continuation(cont); } /* do_setaccess - compile the (SET! (ACCESS var env) value) expression */ LOCAL do_setaccess(form,cont) LVAL form; int cont; { LVAL aform,sym; /* make sure this is an access form */ aform = car(form); if (atom(aform) || car(aform) != xlenter("ACCESS")) xlerror("expecting an ACCESS form",aform); /* get the variable name */ aform = cdr(aform); if (atom(aform) || !symbolp(car(aform))) xlerror("expecting symbol",aform); sym = car(aform); /* compile the environment expression */ aform = cdr(aform); if (atom(aform)) xlerror("expecting environment expression",aform); do_expr(car(aform),C_NEXT); putcbyte(OP_PUSH); /* compile the value expression */ form = cdr(form); if (atom(form)) xlerror("expecting value expression",form); do_expr(car(form),C_NEXT); /* set the variable value */ cd_variable(OP_ASET,sym); do_continuation(cont); } /* do_call - compile a function call */ LOCAL do_call(form,cont) LVAL form; int cont; { int nxt,n; /* save a continuation */ if (cont != C_RETURN) { putcbyte(OP_SAVE); nxt = putcword(0); } /* compile each argument expression */ n = push_args(cdr(form)); /* compile the function itself */ do_expr(car(form),C_NEXT); /* apply the function */ putcbyte(OP_CALL); putcbyte(n); /* target for the continuation */ if (cont != C_RETURN) fixup(nxt); } /* push_args - compile the arguments for a function call */ LOCAL int push_args(form) LVAL form; { int n; if (consp(form)) { n = push_args(cdr(form)); do_expr(car(form),C_NEXT); putcbyte(OP_PUSH); return (n+1); } return (0); } /* do_nary - compile nary operator expressions */ LOCAL do_nary(op,n,form,cont) int op,n; LVAL form; int cont; { if (n < 0 && (n = (-n)) != length(cdr(form))) do_call(form,cont); else { push_nargs(cdr(form),n); putcbyte(op); do_continuation(cont); } } /* push_nargs - compile the arguments for an inline function call */ LOCAL int push_nargs(form,n) LVAL form; int n; { if (consp(form)) { if (n == 0) xlerror("too many arguments",form); if (push_nargs(cdr(form),n-1)) putcbyte(OP_PUSH); do_expr(car(form),C_NEXT); return (TRUE); } if (n) xlerror("too few arguments",form); return (FALSE); } /* do_literal - compile a literal */ LOCAL do_literal(lit,cont) LVAL lit; int cont; { cd_literal(lit); do_continuation(cont); } /* do_identifier - compile an identifier */ LOCAL do_identifier(sym,cont) LVAL sym; int cont; { int lev,off; if (sym == true_lval) putcbyte(OP_T); else if (findvariable(sym,&lev,&off)) cd_evariable(OP_EREF,lev,off); else cd_variable(OP_GREF,sym); do_continuation(cont); } /* do_continuation - compile a continuation */ LOCAL do_continuation(cont) int cont; { switch (cont) { case C_RETURN: putcbyte(OP_RETURN); break; case C_NEXT: break; } } /* add_level - add a nesting level */ LOCAL int add_level() { int oldcbase; /* establish a new environment frame */ rplaca(info,newframe(car(info),1)); rplacd(info,cons(NIL,cdr(info))); /* setup the base of the code for this function */ oldcbase = cbase; cbase = cptr; /* return the old code base */ return (oldcbase); } /* remove_level - remove a nesting level */ LOCAL remove_level(oldcbase) int oldcbase; { /* restore the previous environment */ rplaca(info,cdr(car(info))); rplacd(info,cdr(cdr(info))); /* restore the base and code pointer */ cptr = cbase; cbase = oldcbase; } /* findvariable - find an environment variable */ LOCAL int findvariable(sym,plev,poff) LVAL sym; int *plev,*poff; { int lev,off; LVAL e,a; for (e = car(info), lev = 0; envp(e); e = cdr(e), ++lev) for (a = getelement(car(e),0), off = 1; consp(a); a = cdr(a), ++off) if (sym == car(a)) { *plev = lev; *poff = off; return (TRUE); } return (FALSE); } /* findcvariable - find an environment variable in the current frame */ LOCAL int findcvariable(sym,poff) LVAL sym; int *poff; { int off; LVAL a; a = getelement(car(car(info)),0); for (off = 1; consp(a); a = cdr(a), ++off) if (sym == car(a)) { *poff = off; return (TRUE); } return (FALSE); } /* findliteral - find a literal in the literal frame */ LOCAL int findliteral(lit) LVAL lit; { int o = FIRSTLIT; LVAL t,p; if (t = car(cdr(info))) { for (p = NIL; consp(t); p = t, t = cdr(t), ++o) if (equal(lit,car(t))) return (o); rplacd(p,cons(lit,NIL)); } else rplaca(cdr(info),cons(lit,NIL)); return (o); } /* cd_variable - compile a variable reference */ LOCAL cd_variable(op,sym) int op; LVAL sym; { putcbyte(op); putcbyte(findliteral(sym)); } /* cd_evariable - compile an environment variable reference */ LOCAL cd_evariable(op,lev,off) int op,lev,off; { putcbyte(op); putcbyte(lev); putcbyte(off); } /* cd_literal - compile a literal reference */ LOCAL cd_literal(lit) LVAL lit; { if (lit == NIL) putcbyte(OP_NIL); else if (lit == true_lval) putcbyte(OP_T); else { putcbyte(OP_LIT); putcbyte(findliteral(lit)); } } /* putcbyte - put a code byte into data space */ LOCAL int putcbyte(b) int b; { int adr; if (cptr >= CMAX) xlabort("insufficient code space"); adr = (cptr - cbase); cbuff[cptr++] = b; return (adr); } /* putcword - put a code word into data space */ LOCAL int putcword(w) int w; { int adr; adr = putcbyte(w >> 8); putcbyte(w); return (adr); } /* fixup - fixup a reference chain */ LOCAL fixup(chn) int chn; { int val,hval,nxt; /* store the value into each location in the chain */ val = cptr - cbase; hval = val >> 8; for (; chn; chn = nxt) { nxt = (cbuff[cbase+chn] << 8) | (cbuff[cbase+chn+1]); cbuff[cbase+chn] = hval; cbuff[cbase+chn+1] = val; } } /* length - find the length of a list */ int length(list) LVAL list; { int len; for (len = 0; consp(list); list = cdr(list)) ++len; return (len); } /* instruction output formats */ #define FMT_NONE 0 #define FMT_BYTE 1 #define FMT_LOFF 2 #define FMT_WORD 3 #define FMT_EOFF 4 typedef struct { int ot_code; char *ot_name; int ot_fmt; } OTDEF; OTDEF otab[] = { { OP_BRT, "BRT", FMT_WORD }, { OP_BRF, "BRF", FMT_WORD }, { OP_BR, "BR", FMT_WORD }, { OP_LIT, "LIT", FMT_LOFF }, { OP_GREF, "GREF", FMT_LOFF }, { OP_GSET, "GSET", FMT_LOFF }, { OP_EREF, "EREF", FMT_EOFF }, { OP_ESET, "ESET", FMT_EOFF }, { OP_SAVE, "SAVE", FMT_WORD }, { OP_CALL, "CALL", FMT_BYTE }, { OP_RETURN, "RETURN", FMT_NONE }, { OP_T, "T", FMT_NONE }, { OP_NIL, "NIL", FMT_NONE }, { OP_PUSH, "PUSH", FMT_NONE }, { OP_CLOSE, "CLOSE", FMT_NONE }, { OP_DELAY, "DELAY", FMT_NONE }, { OP_FRAME, "FRAME", FMT_BYTE }, { OP_MVARG, "MVARG", FMT_BYTE }, { OP_MVOARG, "MVOARG", FMT_BYTE }, { OP_MVRARG, "MVRARG", FMT_BYTE }, { OP_ADROP, "ADROP", FMT_NONE }, { OP_ALAST, "ALAST", FMT_NONE }, { OP_AREF, "AREF", FMT_LOFF }, { OP_ASET, "ASET", FMT_LOFF }, {0,0,0} }; /* decode_procedure - decode the instructions in a code object */ decode_procedure(fptr,fun) LVAL fptr,fun; { int len,lc,n; LVAL code,env; code = getcode(fun); env = getenv(fun); len = getslength(getbcode(code)); for (lc = 0; lc < len; lc += n) n = decode_instruction(fptr,code,lc,env); } /* decode_instruction - decode a single bytecode instruction */ int decode_instruction(fptr,code,lc,env) LVAL fptr,code; int lc; LVAL env; { unsigned char *cp; char buf[100]; OTDEF *op; NTDEF *np; int i,n=1; LVAL tmp; /* get a pointer to the bytecodes for this instruction */ cp = getstring(getbcode(code)) + lc; /* show the address and opcode */ if (tmp = getcname(code)) sprintf(buf,"%s:%04x %02x ",getstring(getpname(tmp)),lc,*cp); else { sprintf(buf,AFMT,code); xlputstr(fptr,buf); sprintf(buf,":%04x %02x ",lc,*cp); } xlputstr(fptr,buf); /* display the operands */ for (op = otab; op->ot_name; ++op) if (*cp == op->ot_code) { switch (op->ot_fmt) { case FMT_NONE: sprintf(buf," %s\n",op->ot_name); xlputstr(fptr,buf); break; case FMT_BYTE: sprintf(buf,"%02x %s %02x\n",cp[1],op->ot_name,cp[1]); xlputstr(fptr,buf); n += 1; break; case FMT_LOFF: sprintf(buf,"%02x %s %02x ; ",cp[1],op->ot_name,cp[1]); xlputstr(fptr,buf); xlprin1(getelement(code,cp[1]),fptr); xlterpri(fptr); n += 1; break; case FMT_WORD: sprintf(buf,"%02x %02x %s %02x%02x\n",cp[1],cp[2], op->ot_name,cp[1],cp[2]); xlputstr(fptr,buf); n += 2; break; case FMT_EOFF: if ((i = cp[1]) == 0) tmp = getvnames(code); else { for (tmp = env; i > 1; --i) tmp = cdr(tmp); tmp = getelement(car(tmp),0); } for (i = cp[2]; i > 1; --i) tmp = cdr(tmp); sprintf(buf,"%02x %02x %s %02x %02x ; ",cp[1],cp[2], op->ot_name,cp[1],cp[2]); xlputstr(fptr,buf); xlprin1(car(tmp),fptr); xlterpri(fptr); n += 2; break; } return (n); } /* check for an integrable function */ for (np = ntab; np->nt_name; ++np) if (*cp == np->nt_code) { sprintf(buf," %s\n",np->nt_name); xlputstr(fptr,buf); return (n); } /* unknown opcode */ sprintf(buf," <UNKNOWN>\n"); xlputstr(fptr,buf); return (n); } (tmp); sprintf(buf,"%02x %02x %s %02x %02x ; ",cp[1],cp[2], op->ot_name,cp[1],cp[2]); xlputstr(fptr,buf); xlprin1(car(tmp),fptr); xlterpri(fptr); n += 2; break; } return (n); } /* check for an integrable function */ for (np = ntab; np->nt_name; ++np) if (*cp == np->nt_code) { sprintf(bsrc/xsdmem.c 27 6357 /* Copyright (c) 1988, by David Michael Betz All Rights Reserved Permission is granted for unrestricted non-commercial use */ #include "xscheme.h" /* virtual machine registers */ LVAL xlfun=NIL; /* current function */ LVAL xlenv=NIL; /* current environment */ LVAL xlval=NIL; /* value of most recent instruction */ LVAL *xlsp=NULL; /* value stack pointer */ /* stack limits */ LVAL *xlstkbase=NULL; /* base of value stack */ LVAL *xlstktop=NULL; /* top of value stack (actually, one beyond) */ /* variables shared with xsimage.c */ FIXTYPE total=0; /* total number of bytes of memory in use */ FIXTYPE gccalls=0; /* number of calls to the garbage collector */ /* node space */ NSEGMENT *nsegments=NULL; /* list of node segments */ NSEGMENT *nslast=NULL; /* last node segment */ int nscount=0; /* number of node segments */ FIXTYPE nnodes=0; /* total number of nodes */ FIXTYPE nfree=0; /* number of nodes in free list */ LVAL fnodes=NIL; /* list of free nodes */ /* vector (and string) space */ VSEGMENT *vsegments=NULL; /* list of vector segments */ VSEGMENT *vscurrent=NULL; /* current vector segment */ int vscount=0; /* number of vector segments */ LVAL *vfree=NULL; /* next free location in vector space */ LVAL *vtop=NULL; /* top of vector space */ /* external variables */ extern LVAL s_unbound; /* *UNBOUND* symbol */ extern LVAL obarray; /* *OBARRAY* symbol */ extern LVAL default_object; /* default object */ extern LVAL eof_object; /* eof object */ extern LVAL true_lval; /* truth value */ /* external routines */ extern unsigned char *calloc(); /* forward declarations */ FORWARD LVAL allocnode(); FORWARD LVAL allocvector(); /* cons - construct a new cons node */ LVAL cons(x,y) LVAL x,y; { LVAL nnode; /* get a free node */ if ((nnode = fnodes) == NIL) { check(2); push(x); push(y); findmemory(); if ((nnode = fnodes) == NIL) xlabort("insufficient node space"); drop(2); } /* unlink the node from the free list */ fnodes = cdr(nnode); --nfree; /* initialize the new node */ nnode->n_type = CONS; rplaca(nnode,x); rplacd(nnode,y); /* return the new node */ return (nnode); } /* newframe - create a new environment frame */ LVAL newframe(parent,size) LVAL parent; int size; { LVAL frame; frame = cons(newvector(size),parent); frame->n_type = ENV; return (frame); } /* cvstring - convert a string to a string node */ LVAL cvstring(str) unsigned char *str; { LVAL val; val = newstring(strlen(str)+1); strcpy(getstring(val),str); return (val); } /* cvsymbol - convert a string to a symbol */ LVAL cvsymbol(pname) unsigned char *pname; { LVAL val; val = allocvector(SYMBOL,SYMSIZE); cpush(val); setvalue(val,s_unbound); setpname(val,cvstring(pname)); setplist(val,NIL); return (pop()); } /* cvfixnum - convert an integer to a fixnum node */ LVAL cvfixnum(n) FIXTYPE n; { LVAL val; if (n >= SFIXMIN && n <= SFIXMAX) return (cvsfixnum(n)); val = allocnode(FIXNUM); val->n_int = n; return (val); } /* cvflonum - convert a floating point number to a flonum node */ LVAL cvflonum(n) FLOTYPE n; { LVAL val; val = allocnode(FLONUM); val->n_flonum = n; return (val); } /* cvchar - convert an integer to a character node */ LVAL cvchar(ch) int ch; { LVAL val; val = allocnode(CHAR); val->n_chcode = ch; return (val); } /* cvclosure - convert code and an environment to a closure */ LVAL cvclosure(code,env) LVAL code,env; { LVAL val; val = cons(code,env); val->n_type = CLOSURE; return (val); } /* cvpromise - convert a procedure to a promise */ LVAL cvpromise(code,env) LVAL code,env; { LVAL val; val = cons(cvclosure(code,env),NIL); val->n_type = PROMISE; return (val); } /* cvmethod - convert code and an environment to a method */ LVAL cvmethod(code,class) LVAL code,class; { LVAL val; val = cons(code,class); val->n_type = METHOD; return (val); } /* cvsubr - convert a function to a subr/xsubr */ LVAL cvsubr(type,fcn,offset) int type; LVAL (*fcn)(); int offset; { LVAL val; val = allocnode(type); val->n_subr = fcn; val->n_offset = offset; return (val); } /* cvport - convert a file pointer to an port */ LVAL cvport(fp,flags) FILE *fp; int flags; { LVAL val; val = allocnode(PORT); setfile(val,fp); setsavech(val,'\0'); setpflags(val,flags); return (val); } /* newvector - allocate and initialize a new vector */ LVAL newvector(size) int size; { return (allocvector(VECTOR,size)); } /* newstring - allocate and initialize a new string */ LVAL newstring(size) int size; { LVAL val; val = allocvector(STRING,btow_size(size)); val->n_vsize = size; return (val); } /* newcode - create a new code object */ LVAL newcode(nlits) int nlits; { return (allocvector(CODE,nlits)); } /* newcontinuation - create a new continuation object */ LVAL newcontinuation(size) int size; { return (allocvector(CONTINUATION,size)); } /* newobject - allocate and initialize a new object */ LVAL newobject(cls,size) LVAL cls; int size; { LVAL val; val = allocvector(OBJECT,size+2); /* class, ivars */ setclass(val,cls); return (val); } /* allocnode - allocate a new node */ LOCAL LVAL allocnode(type) int type; { LVAL nnode; /* get a free node */ if ((nnode = fnodes) == NIL) { findmemory(); if ((nnode = fnodes) == NIL) xlabort("insufficient node space"); } /* unlink the node from the free list */ fnodes = cdr(nnode); --nfree; /* initialize the new node */ nnode->n_type = type; rplacd(nnode,NIL); /* return the new node */ return (nnode); } /* findmemory - garbage collect, then add more node space if necessary */ LOCAL findmemory() { /* first try garbage collecting */ gc(); /* expand memory only if less than one segment is free */ if (nfree < (long)NSSIZE) nexpand(NSSIZE); } /* nexpand - expand node space */ int nexpand(size) int size; { NSEGMENT *newnsegment(),*newseg; LVAL p; int i; /* allocate the new segment */ if ((newseg = newnsegment(size)) != NULL) { /* add each new node to the free list */ p = &newseg->ns_data[0]; for (i = NSSIZE; --i >= 0; ++p) { p->n_type = FREE; p->n_flags = 0; rplacd(p,fnodes); fnodes = p; } } return (newseg != NULL); } /* allocvector - allocate and initialize a new vector node */ LOCAL LVAL allocvector(type,size) int type,size; { register LVAL val,*p; register int i; /* get a free node */ if ((val = fnodes) == NIL) { findmemory(); if ((val = fnodes) == NIL) xlabort("insufficient node space"); } /* unlink the node from the free list */ fnodes = cdr(fnodes); --nfree; /* initialize the vector node */ val->n_type = type; val->n_vsize = size; val->n_vdata = NULL; cpush(val); /* add space for the backpointer */ ++size; /* make sure there's enough space */ if (!VCOMPARE(vfree,size,vtop) && !checkvmemory(size) && !findvmemory(size)) xlabort("insufficient vector space"); /* allocate the next available block */ p = vfree; vfree += size; /* store the backpointer */ *p++ = top(); val->n_vdata = p; /* set all the elements to NIL */ for (i = size; i > 1; --i) *p++ = NIL; /* return the new vector */ return (pop()); } /* findvmemory - find vector memory */ LOCAL int findvmemory(size) int size; { /* try garbage collecting */ gc(); /* check to see if we found enough memory */ if (VCOMPARE(vfree,size,vtop) || checkvmemory(size)) return (TRUE); /* expand vector space */ return (makevmemory(size)); } /* checkvmemory - check for vector memory (used by 'xsimage.c') */ int checkvmemory(size) int size; { VSEGMENT *vseg; for (vseg = vsegments; vseg != NULL; vseg = vseg->vs_next) if (vseg != vscurrent && VCOMPARE(vseg->vs_free,size,vseg->vs_top)) { if (vscurrent != NULL) vscurrent->vs_free = vfree; vfree = vseg->vs_free; vtop = vseg->vs_top; vscurrent = vseg; return (TRUE); } return (FALSE); } /* makevmemory - make vector memory (used by 'xsimage.c') */ int makevmemory(size) int size; { return (vexpand(size < VSSIZE ? VSSIZE : size)); } /* vexpand - expand vector space */ int vexpand(size) int size; { VSEGMENT *newvsegment(),*vseg; /* allocate the new segment */ if ((vseg = newvsegment(size)) != NULL) { /* initialize the new segment and make it current */ if (vscurrent != NULL) vscurrent->vs_free = vfree; vfree = vseg->vs_free; vtop = vseg->vs_top; vscurrent = vseg; } return (vseg != NULL); } /* newnsegment - create a new node segment */ NSEGMENT *newnsegment(n) unsigned int n; { NSEGMENT *newseg; /* allocate the new segment */ if ((newseg = (NSEGMENT *)calloc(1,nsegsize(n))) == NULL) return (NULL); /* initialize the new segment */ newseg->ns_size = n; newseg->ns_next = NULL; if (nsegments) nslast->ns_next = newseg; else nsegments = newseg; nslast = newseg; /* update the statistics */ total += (long)nsegsize(n); nnodes += (long)n; nfree += (long)n; ++nscount; /* return the new segment */ return (newseg); } /* newvsegment - create a new vector segment */ VSEGMENT *newvsegment(n) unsigned int n; { VSEGMENT *newseg; /* allocate the new segment */ if ((newseg = (VSEGMENT *)calloc(1,vsegsize(n))) == NULL) return (NULL); /* initialize the new segment */ newseg->vs_free = &newseg->vs_data[0]; newseg->vs_top = newseg->vs_free + n; newseg->vs_next = vsegments; vsegments = newseg; /* update the statistics */ total += (long)vsegsize(n); ++vscount; /* return the new segment */ return (newseg); } /* gc - garbage collect */ gc() { register LVAL *p,tmp; int compact(); /* mark the obarray and the current environment */ if (obarray && ispointer(obarray)) mark(obarray); if (xlfun && ispointer(xlfun)) mark(xlfun); if (xlenv && ispointer(xlenv)) mark(xlenv); if (xlval && ispointer(xlval)) mark(xlval); if (default_object && ispointer(default_object)) mark(default_object); if (eof_object && ispointer(eof_object)) mark(eof_object); if (true_lval && ispointer(true_lval)) mark(true_lval); /* mark the stack */ for (p = xlsp; p < xlstktop; ++p) if ((tmp = *p) && ispointer(tmp)) mark(tmp); /* compact vector space */ gc_protect(compact); /* sweep memory collecting all unmarked nodes */ sweep(); /* count the gc call */ ++gccalls; } /* mark - mark all accessible nodes */ LOCAL mark(ptr) LVAL ptr; { register LVAL this,prev,tmp; /* initialize */ prev = NIL; this = ptr; /* mark this node */ for (;;) { /* descend as far as we can */ while (!(this->n_flags & MARK)) /* mark this node and trace its children */ switch (this->n_type) { case CONS: /* mark cons-like nodes */ case CLOSURE: case METHOD: case PROMISE: case ENV: this->n_flags |= MARK; if ((tmp = car(this)) && ispointer(tmp)) { this->n_flags |= LEFT; rplaca(this,prev); prev = this; this = tmp; } else if ((tmp = cdr(this)) && ispointer(tmp)) { rplacd(this,prev); prev = this; this = tmp; } break; case SYMBOL: /* mark vector-like nodes */ case OBJECT: case VECTOR: case CODE: case CONTINUATION: this->n_flags |= MARK; markvector(this); break; case FIXNUM: /* mark objects that don't contain pointers */ case FLONUM: case STRING: case PORT: case SUBR: case XSUBR: case CSUBR: case CHAR: this->n_flags |= MARK; break; default: /* bad object type */ xlfatal("bad object type %d\n",this->n_type); break; } /* backup to a point where we can continue descending */ for (;;) /* make sure there is a previous node */ if (prev) { if (prev->n_flags & LEFT) { /* came from left side */ prev->n_flags &= ~LEFT; tmp = car(prev); rplaca(prev,this); if ((this = cdr(prev)) && ispointer(this)) { rplacd(prev,tmp); break; } } else { /* came from right side */ tmp = cdr(prev); rplacd(prev,this); } this = prev; /* step back up the branch */ prev = tmp; } /* no previous node, must be done */ else return; } } /* markvector - mark a vector-like node */ LOCAL markvector(vect) LVAL vect; { register LVAL tmp,*p; register int n; if (p = vect->n_vdata) { n = getsize(vect); while (--n >= 0) if ((tmp = *p++) && ispointer(tmp)) mark(tmp); } } /* compact - compact vector space */ LOCAL compact() { VSEGMENT *vseg; /* store the current segment information */ if (vscurrent) vscurrent->vs_free = vfree; /* compact each vector segment */ for (vseg = vsegments; vseg != NULL; vseg = vseg->vs_next) compact_vector(vseg); /* make the first vector segment current */ if (vscurrent = vsegments) { vfree = vscurrent->vs_free; vtop = vscurrent->vs_top; } } /* compact_vector - compact a vector segment */ LOCAL compact_vector(vseg) VSEGMENT *vseg; { register LVAL *vdata,*vnext,*vfree,vector; register int vsize; vdata = vnext = &vseg->vs_data[0]; vfree = vseg->vs_free; while (vdata < vfree) { vector = *vdata; vsize = (vector->n_type == STRING ? btow_size(vector->n_vsize) : vector->n_vsize) + 1; if (vector->n_flags & MARK) { if (vdata == vnext) { vdata += vsize; vnext += vsize; } else { vector->n_vdata = vnext + 1; while (--vsize >= 0) *vnext++ = *vdata++; } } else vdata += vsize; } vseg->vs_free = vnext; } /* sweep - sweep all unmarked nodes and add them to the free list */ LOCAL sweep() { NSEGMENT *nseg; /* empty the free list */ fnodes = NIL; nfree = 0L; /* sweep each node segment */ for (nseg = nsegments; nseg != NULL; nseg = nseg->ns_next) sweep_segment(nseg); } /* sweep_segment - sweep a node segment */ LOCAL sweep_segment(nseg) NSEGMENT *nseg; { register FIXTYPE n; register LVAL p; /* add all unmarked nodes */ for (p = &nseg->ns_data[0], n = nseg->ns_size; --n >= 0L; ++p) if (!(p->n_flags & MARK)) { switch (p->n_type) { case PORT: if (getfile(p)) osclose(getfile(p)); break; } p->n_type = FREE; rplacd(p,fnodes); fnodes = p; ++nfree; } else p->n_flags &= ~MARK; } /* xlminit - initialize the dynamic memory module */ xlminit(ssize) unsigned int ssize; { unsigned int n; /* initialize our internal variables */ gccalls = 0; total = 0L; /* initialize node space */ nsegments = nslast = NULL; nscount = 0; nnodes = nfree = 0L; fnodes = NIL; /* initialize vector space */ vsegments = vscurrent = NULL; vscount = 0; vfree = vtop = NULL; /* allocate the value stack */ n = ssize * sizeof(LVAL); if ((xlstkbase = (LVAL *)calloc(1,n)) == NULL) xlfatal("insufficient memory"); total += (long)n; /* initialize structures that are marked by the collector */ obarray = default_object = eof_object = true_lval = NIL; xlfun = xlenv = xlval = NIL; /* initialize the stack */ xlsp = xlstktop = xlstkbase + ssize; } itialize vector space */ vsegments = vscurrent = NULL; vscount = 0; vfree = vtop = NULL; /* allocate the value stack */ n = ssize * sizeof(LVAL); if ((xlstkbase = (LVAL *)calloc(1,n)) ==src/xsftab.c /* Copyright (c) 1988, by David Michael Betz All Rights Reserved Permission is granted for unrestricted non-commercial use */ #include "xscheme.h" /* external variables */ extern LVAL s_stdin,s_stdout; /* external functions */ extern LVAL xapply(),xcallcc(),xmap(),xmap1(),xforeach(),xforeach1(), xforce(),xforce1(),xcallwi(),xcallwo(),xwithfile1(), xload(),xloadnoisily(),xload1(), xsendsuper(),clnew(),clisnew(),clanswer(), obisnew(),obclass(),obshow(), xcons(),xcar(),xcdr(), xcaar(),xcadr(),xcdar(),xcddr(), xcaaar(),xcaadr(),xcadar(),xcaddr(), xcdaar(),xcdadr(),xcddar(),xcdddr(), xcaaaar(),xcaaadr(),xcaadar(),xcaaddr(), xcadaar(),xcadadr(),xcaddar(),xcadddr(), xcdaaar(),xcdaadr(),xcdadar(),xcdaddr(), xcddaar(),xcddadr(),xcdddar(),xcddddr(), xsetcar(),xsetcdr(),xlist(),xliststar(), xappend(),xreverse(),xlastpair(),xlength(),xlistref(),xlisttail(), xmember(),xmemv(),xmemq(),xassoc(),xassv(),xassq(), xsymvalue(),xsetsymvalue(),xsymplist(),xsetsymplist(),xgensym(), xboundp(),xget(),xput(), xtheenvironment(),xprocenvironment(),xenvp(),xenvbindings(),xenvparent(), xvector(),xmakevector(),xvlength(),xvref(),xvset(), xvectlist(),xlistvect(), xmakearray(),xaref(),xaset(), xsymstr(),xstrsym(), xnull(),xatom(),xlistp(),xnumberp(),xbooleanp(), xpairp(),xsymbolp(),xintegerp(),xrealp(),xcharp(),xstringp(),xvectorp(), xprocedurep(),xobjectp(),xdefaultobjectp(), xinputportp(),xoutputportp(),xportp(), xeq(),xeqv(),xequal(), xzerop(),xpositivep(),xnegativep(),xoddp(),xevenp(), xexactp(),xinexactp(), xadd1(),xsub1(),xabs(),xgcd(),xrandom(), xadd(),xsub(),xmul(),xdiv(),xquo(),xrem(),xmin(),xmax(), xsin(),xcos(),xtan(),xasin(),xacos(),xatan(), xxexp(),xsqrt(),xexpt(),xxlog(),xtruncate(),xfloor(),xceiling(),xround(), xlogand(),xlogior(),xlogxor(),xlognot(), xlss(),xleq(),xeql(),xgeq(),xgtr(), xstrlen(),xstrnullp(),xstrappend(),xstrref(),xsubstring(), xstrlist(),xliststring(), xstrlss(),xstrleq(),xstreql(),xstrgeq(),xstrgtr(), xstrilss(),xstrileq(),xstrieql(),xstrigeq(),xstrigtr(), xcharint(),xintchar(), xchrlss(),xchrleq(),xchreql(),xchrgeq(),xchrgtr(), xchrilss(),xchrileq(),xchrieql(),xchrigeq(),xchrigtr(), xread(),xrdchar(),xrdbyte(),xrdshort(),xrdlong(),xeofobjectp(), xwrite(),xwrchar(),xwrbyte(),xwrshort(),xwrlong(), xdisplay(),xnewline(),xprint(),xprbreadth(),xprdepth(), xopeni(),xopeno(),xopena(),xopenu(),xclosei(),xcloseo(),xclose(), xgetfposition(),xsetfposition(),xcurinput(),xcuroutput(), xtranson(),xtransoff(),xgetarg(),xexit(),xcompile(),xdecompile(),xgc(), xsave(),xrestore(),xtraceon(),xtraceoff(),xreset(),xerror(), xicar(),xicdr(),xisetcar(),xisetcdr(),xivlength(),xivref(),xivset(); /* include machine specific declarations */ #include "osdefs.h" int xsubrcnt = 12; /* number of XSUBR functions */ int csubrcnt = 17; /* number of CSUBR functions + xsubrcnt */ /* built-in functions */ FUNDEF funtab[] = { /* functions that call eval or apply (# must match xsubrcnt) */ { "APPLY", xapply }, { "CALL-WITH-CURRENT-CONTINUATION", xcallcc }, { "CALL/CC", xcallcc }, { "MAP", xmap }, { "FOR-EACH", xforeach }, { "CALL-WITH-INPUT-FILE", xcallwi }, { "CALL-WITH-OUTPUT-FILE", xcallwo }, { "LOAD", xload }, { "LOAD-NOISILY", xloadnoisily }, { "SEND-SUPER", xsendsuper }, { "%CLASS-NEW", clnew }, { "FORCE", xforce }, /* continuations for xsubrs (# must match csubrcnt) */ { "%MAP1", xmap1 }, { "%FOR-EACH1", xforeach1 }, { "%WITH-FILE1", xwithfile1 }, { "%LOAD1", xload1 }, { "%FORCE1", xforce1 }, /* methods */ { "%CLASS-ISNEW", clisnew }, { "%CLASS-ANSWER", clanswer }, { "%OBJECT-ISNEW", obisnew }, { "%OBJECT-CLASS", obclass }, { "%OBJECT-SHOW", obshow }, /* list functions */ { "CONS", xcons }, { "CAR", xcar }, { "CDR", xcdr }, { "CAAR", xcaar }, { "CADR", xcadr }, { "CDAR", xcdar }, { "CDDR", xcddr }, { "CAAAR", xcaaar }, { "CAADR", xcaadr }, { "CADAR", xcadar }, { "CADDR", xcaddr }, { "CDAAR", xcdaar }, { "CDADR", xcdadr }, { "CDDAR", xcddar }, { "CDDDR", xcdddr }, { "CAAAAR", xcaaaar }, { "CAAADR", xcaaadr }, { "CAADAR", xcaadar }, { "CAADDR", xcaaddr }, { "CADAAR", xcadaar }, { "CADADR", xcadadr }, { "CADDAR", xcaddar }, { "CADDDR", xcadddr }, { "CDAAAR", xcdaaar }, { "CDAADR", xcdaadr }, { "CDADAR", xcdadar }, { "CDADDR", xcdaddr }, { "CDDAAR", xcddaar }, { "CDDADR", xcddadr }, { "CDDDAR", xcdddar }, { "CDDDDR", xcddddr }, { "LIST", xlist }, { "LIST*", xliststar }, { "APPEND", xappend }, { "REVERSE", xreverse }, { "LAST-PAIR", xlastpair }, { "LENGTH", xlength }, { "MEMBER", xmember }, { "MEMV", xmemv }, { "MEMQ", xmemq }, { "ASSOC", xassoc }, { "ASSV", xassv }, { "ASSQ", xassq }, { "LIST-REF", xlistref }, { "LIST-TAIL", xlisttail }, /* destructive list functions */ { "SET-CAR!", xsetcar }, { "SET-CDR!", xsetcdr }, /* symbol functions */ { "BOUND?", xboundp }, { "SYMBOL-VALUE", xsymvalue }, { "SET-SYMBOL-VALUE!", xsetsymvalue }, { "SYMBOL-PLIST", xsymplist }, { "SET-SYMBOL-PLIST!", xsetsymplist }, { "GENSYM", xgensym }, { "GET", xget }, { "PUT", xput }, /* environment functions */ { "THE-ENVIRONMENT", xtheenvironment }, { "PROCEDURE-ENVIRONMENT", xprocenvironment}, { "ENVIRONMENT?", xenvp }, { "ENVIRONMENT-BINDINGS", xenvbindings }, { "ENVIRONMENT-PARENT", xenvparent }, /* vector functions */ { "VECTOR", xvector }, { "MAKE-VECTOR", xmakevector }, { "VECTOR-LENGTH", xvlength }, { "VECTOR-REF", xvref }, { "VECTOR-SET!", xvset }, /* array functions */ { "MAKE-ARRAY", xmakearray }, { "ARRAY-REF", xaref }, { "ARRAY-SET!", xaset }, /* conversion functions */ { "SYMBOL->STRING", xsymstr }, { "STRING->SYMBOL", xstrsym }, { "VECTOR->LIST", xvectlist }, { "LIST->VECTOR", xlistvect }, { "STRING->LIST", xstrlist }, { "LIST->STRING", xliststring }, { "CHAR->INTEGER", xcharint }, { "INTEGER->CHAR", xintchar }, /* predicate functions */ { "NULL?", xnull }, { "ATOM?", xatom }, { "LIST?", xlistp }, { "NUMBER?", xnumberp }, { "BOOLEAN?", xbooleanp }, { "PAIR?", xpairp }, { "SYMBOL?", xsymbolp }, { "COMPLEX?", xrealp }, /*(1)*/ { "REAL?", xrealp }, { "RATIONAL?", xintegerp }, /*(1)*/ { "INTEGER?", xintegerp }, { "CHAR?", xcharp }, { "STRING?", xstringp }, { "VECTOR?", xvectorp }, { "PROCEDURE?", xprocedurep }, { "PORT?", xportp }, { "INPUT-PORT?", xinputportp }, { "OUTPUT-PORT?", xoutputportp }, { "OBJECT?", xobjectp }, { "EOF-OBJECT?", xeofobjectp }, { "DEFAULT-OBJECT?", xdefaultobjectp }, { "EQ?", xeq }, { "EQV?", xeqv }, { "EQUAL?", xequal }, /* arithmetic functions */ { "ZERO?", xzerop }, { "POSITIVE?", xpositivep }, { "NEGATIVE?", xnegativep }, { "ODD?", xoddp }, { "EVEN?", xevenp }, { "EXACT?", xexactp }, { "INEXACT?", xinexactp }, { "TRUNCATE", xtruncate }, { "FLOOR", xfloor }, { "CEILING", xceiling }, { "ROUND", xround }, { "1+", xadd1 }, { "-1+", xsub1 }, { "ABS", xabs }, { "GCD", xgcd }, { "RANDOM", xrandom }, { "+", xadd }, { "-", xsub }, { "*", xmul }, { "/", xdiv }, { "QUOTIENT", xquo }, { "REMAINDER", xrem }, { "MIN", xmin }, { "MAX", xmax }, { "SIN", xsin }, { "COS", xcos }, { "TAN", xtan }, { "ASIN", xasin }, { "ACOS", xacos }, { "ATAN", xatan }, { "EXP", xxexp }, { "SQRT", xsqrt }, { "EXPT", xexpt }, { "LOG", xxlog }, /* bitwise logical functions */ { "LOGAND", xlogand }, { "LOGIOR", xlogior }, { "LOGXOR", xlogxor }, { "LOGNOT", xlognot }, /* numeric comparison functions */ { "<", xlss }, { "<=", xleq }, { "=", xeql }, { ">=", xgeq }, { ">", xgtr }, /* string functions */ { "STRING-LENGTH", xstrlen }, { "STRING-NULL?", xstrnullp }, { "STRING-APPEND", xstrappend }, { "STRING-REF", xstrref }, { "SUBSTRING", xsubstring }, { "STRING<?", xstrlss }, { "STRING<=?", xstrleq }, { "STRING=?", xstreql }, { "STRING>=?", xstrgeq }, { "STRING>?", xstrgtr }, { "STRING-CI<?", xstrilss }, { "STRING-CI<=?", xstrileq }, { "STRING-CI=?", xstrieql }, { "STRING-CI>=?", xstrigeq }, { "STRING-CI>?", xstrigtr }, /* character functions */ { "CHAR<?", xchrlss }, { "CHAR<=?", xchrleq }, { "CHAR=?", xchreql }, { "CHAR>=?", xchrgeq }, { "CHAR>?", xchrgtr }, { "CHAR-CI<?", xchrilss }, { "CHAR-CI<=?", xchrileq }, { "CHAR-CI=?", xchrieql }, { "CHAR-CI>=?", xchrigeq }, { "CHAR-CI>?", xchrigtr }, /* I/O functions */ { "READ", xread }, { "READ-CHAR", xrdchar }, { "READ-BYTE", xrdbyte }, { "READ-SHORT", xrdshort }, { "READ-LONG", xrdlong }, { "WRITE", xwrite }, { "WRITE-CHAR", xwrchar }, { "WRITE-BYTE", xwrbyte }, { "WRITE-SHORT", xwrshort }, { "WRITE-LONG", xwrlong }, { "DISPLAY", xdisplay }, { "PRINT", xprint }, { "NEWLINE", xnewline }, /* print control functions */ { "PRINT-BREADTH", xprbreadth }, { "PRINT-DEPTH", xprdepth }, /* file I/O functions */ { "OPEN-INPUT-FILE", xopeni }, { "OPEN-OUTPUT-FILE", xopeno }, { "OPEN-APPEND-FILE", xopena }, { "OPEN-UPDATE-FILE", xopenu }, { "CLOSE-PORT", xclose }, { "CLOSE-INPUT-PORT", xclosei }, { "CLOSE-OUTPUT-PORT", xcloseo }, { "GET-FILE-POSITION", xgetfposition }, { "SET-FILE-POSITION!", xsetfposition }, { "CURRENT-INPUT-PORT", xcurinput }, { "CURRENT-OUTPUT-PORT", xcuroutput }, /* utility functions */ { "TRANSCRIPT-ON", xtranson }, { "TRANSCRIPT-OFF", xtransoff }, { "GETARG", xgetarg }, { "EXIT", xexit }, { "COMPILE", xcompile }, { "DECOMPILE", xdecompile }, { "GC", xgc }, { "SAVE", xsave }, { "RESTORE", xrestore }, { "RESET", xreset }, { "ERROR", xerror }, /* debugging functions */ { "TRACE-ON", xtraceon }, { "TRACE-OFF", xtraceoff }, /* internal functions */ { "%CAR", xicar }, { "%CDR", xicdr }, { "%SET-CAR!", xisetcar }, { "%SET-CDR!", xisetcdr }, { "%VECTOR-LENGTH", xivlength }, { "%VECTOR-REF", xivref }, { "%VECTOR-SET!", xivset }, /* include machine specific table entries */ #include "osptrs.h" {0,0} /* end of table marker */ }; /* Notes: (1) This version only supports integers and reals. */ /* curinput - get the current input port */ LVAL curinput() { return (getvalue(s_stdin)); } /* curoutput - get the current output port */ LVAL curoutput() { return (getvalue(s_stdout)); } /* eq - internal 'eq?' function */ int eq(arg1,arg2) LVAL arg